diff --git a/Frames.cabal b/Frames.cabal new file mode 100644 --- /dev/null +++ b/Frames.cabal @@ -0,0 +1,166 @@ +name: Frames +version: 0.1.0.0 +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 + each row of data is inferred from data, which can + then be streamed from disk, or worked with in + memory. +license: BSD3 +license-file: LICENSE +author: Anthony Cowley +maintainer: acowley@gmail.com +copyright: Copyright (C) 2014-2015 Anthony Cowley +category: Data +build-type: Simple +extra-source-files: benchmarks/*.hs benchmarks/*.py + demo/Main.hs + data/GetData.hs +cabal-version: >=1.10 + +source-repository head + type: git + location: http://github.com/acowley/Frames.git + +flag demos + description: Build demonstration programs + default: False + manual: True + +library + exposed-modules: Frames + Frames.Col + Frames.ColumnTypeable + Frames.ColumnUniverse + Frames.CoRec + Frames.CSV + Frames.Exploration + Frames.Frame + Frames.InCore + Frames.Melt + Frames.Rec + Frames.RecF + Frames.RecLens + Frames.TypeLevel + other-extensions: DataKinds, GADTs, KindSignatures, TypeFamilies, + TypeOperators, ConstraintKinds, StandaloneDeriving, + UndecidableInstances, ScopedTypeVariables, + OverloadedStrings + build-depends: base >=4.7 && <4.9, + ghc-prim >=0.3 && <0.5, + primitive >= 0.6 && < 0.7, + text >= 1.1.1.0, + template-haskell, + transformers, + vector, + readable >= 0.3.1, + pipes >= 4.1 && < 5, + vinyl >= 0.5 && < 0.6 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +-- Get the large-ish 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, zip-archive + hs-source-dirs: data + default-language: Haskell2010 + ghc-options: -Wall + +-- Demonstrate using the Chart library to produce figures +executable plot + if !flag(demos) + buildable: False + main-is: Plot.hs + if flag(demos) + build-depends: base, Frames, + lens-family-core, vector, text, + template-haskell, + pipes >= 4.1.5 && < 4.2, + Chart >= 1.5 && < 1.6, + Chart-diagrams >= 1.5 && < 1.6, + diagrams-rasterific >= 1.3 && < 1.4, + diagrams-lib >= 1.3 && < 1.4, + readable, containers, statistics + hs-source-dirs: demo + default-language: Haskell2010 + +executable plot2 + if !flag(demos) + buildable: False + main-is: Plot2.hs + if flag(demos) + build-depends: base, Frames, + lens-family-core, vector, text, template-haskell, + pipes >= 4.1.5 && < 4.2, + Chart >= 1.5 && < 1.6, + Chart-diagrams >= 1.5 && < 1.6, + diagrams-rasterific >= 1.3 && < 1.4, + diagrams-lib >= 1.3 && < 1.4, + readable, containers, statistics + hs-source-dirs: demo + default-language: Haskell2010 + +-- Miscellaneous tooling around a data file +executable demo + if !flag(demos) + buildable: False + main-is: Main.hs + if flag(demos) + build-depends: base, list-t, lens-family-core, transformers, Frames, + vector, text, template-haskell, ghc-prim, readable, + pipes >= 4.1.5 && < 4.2 + hs-source-dirs: demo + default-language: Haskell2010 + ghc-options: -O2 -fllvm + +executable tutorial + if !flag(demos) + buildable: False + main-is: TutorialMain.hs + if flag(demos) + build-depends: base, Frames, + lens-family-core, vector, text, template-haskell, readable, + foldl >= 1.1.0 && < 1.2, + pipes >= 4.1.5 && < 4.2 + hs-source-dirs: demo + default-language: Haskell2010 + +-- A short demo to compare with Pandas +executable benchdemo + if !flag(demos) + buildable: False + main-is: BenchDemo.hs + if flag(demos) + build-depends: base, Frames, lens-family-core, + foldl >= 1.1.0 && < 1.2, + pipes >= 4.1.5 && < 4.2 + hs-source-dirs: benchmarks + default-language: Haskell2010 + ghc-options: -O2 -fllvm + +-- A demonstration of dealing with missing data. Provided for source +-- code and experimentation rather than a useful executable. +executable missing + if !flag(demos) + buildable: False + main-is: MissingData.hs + if flag(demos) + build-depends: base, Frames, vinyl + hs-source-dirs: demo + default-language: Haskell2010 + +-- Benchmark showing tradeoffs of differing processing needs +benchmark insurance + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: InsuranceBench.hs + build-depends: base, criterion, Frames, lens-family-core, transformers, + pipes >= 4.1.5 && < 4.2 + ghc-options: -O2 -fllvm + default-language: Haskell2010 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Anthony Cowley + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Anthony Cowley nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/benchmarks/BenchDemo.hs b/benchmarks/BenchDemo.hs new file mode 100644 --- /dev/null +++ b/benchmarks/BenchDemo.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DataKinds, FlexibleContexts, TemplateHaskell #-} +-- | 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@ +import Control.Applicative +import qualified Control.Foldl as F +import Frames +import Pipes.Prelude (fold) + +tableTypes "Ins" "data/FL2.csv" + +main :: IO () +main = do (lat,lng,n) <- F.purely fold f (readTable "data/FL2.csv") + print $ lat / n + print $ lng / n + where f :: F.Fold Ins (Double,Double,Double) + f = (,,) <$> F.handles pointLatitude F.sum + <*> F.handles pointLongitude F.sum + <*> F.genericLength diff --git a/benchmarks/InsuranceBench.hs b/benchmarks/InsuranceBench.hs new file mode 100644 --- /dev/null +++ b/benchmarks/InsuranceBench.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE BangPatterns, + DataKinds, + FlexibleContexts, + TemplateHaskell #-} +import Criterion.Main +import qualified Data.Foldable as F +import Data.Functor.Identity +import Frames +import qualified Pipes as P +import qualified Pipes.Prelude as P + +tableTypes "Ins" "data/FL2.csv" + +type TinyIns = Record [PolicyID, PointLatitude, PointLongitude] + +tblP :: P.Producer Ins IO () +tblP = readTable "data/FL2.csv" + +-- Strict pair +data P a = P !a !a + +-- | Perform two consecutive folds of streamed-in data. +pipeBench :: IO (P Double) +pipeBench = do (n,sumLat) <- + P.fold (\ !(!i, !s) r -> (i+1, s+rget pointLatitude r)) + (0::Int,0) + id + tbl + sumLong <- P.fold (\s r -> (s + rget pointLongitude r)) 0 id tbl + return $! P (sumLat / fromIntegral n) (sumLong / fromIntegral n) + where tbl = P.for tblP (P.yield . rcast) :: P.Producer TinyIns IO () + +-- | Perform two consecutive folds after first streaming all data into +-- an in-memory representation. +pipeBenchInCore :: IO (P Double) +pipeBenchInCore = + do tbl <- inCore tblP :: IO (P.Producer Ins Identity ()) + let Identity (n,sumLat) = + P.fold (\ !(!i, !s) r -> (i+1, s+rget pointLatitude r)) + (0::Int,0) + id + tbl + Identity sumLong = + P.fold (\s r -> (s + rget pointLongitude r)) 0 id tbl + return $! P (sumLat / fromIntegral n) (sumLong / fromIntegral n) + +-- | Perform two consecutive folds after first projecting a subset of +-- fields while streaming data into an in-memory representation. +pipeBenchInCore' :: IO (P Double) +pipeBenchInCore' = + do tbl <- inCore $ P.for tblP (P.yield . rcast) + :: IO (P.Producer TinyIns Identity ()) + let Identity (n,sumLat) = + P.fold (\ !(!i, !s) r -> (i+1, s+rget pointLatitude r)) + (0::Int,0) + id + tbl + Identity sumLong = + P.fold (\s r -> (s + rget pointLongitude r)) 0 id tbl + return $! P (sumLat / fromIntegral n) (sumLong / fromIntegral n) + +-- | Perform two consecutive folds after projecting a subset of an +-- in-memory reprsentation. +pipeBenchAoS :: IO (P Double) +pipeBenchAoS = do tbl <- inCoreAoS' rcast tblP :: IO (Frame TinyIns) + let (n,sumLat) = + F.foldl' (\ !(!i,!s) r -> (i+1, s+rget pointLatitude r)) + (0::Int,0) + tbl + sumLong = + F.foldl' (\ !s r -> (s + rget pointLongitude r)) 0 tbl + return $! P (sumLat / fromIntegral n) (sumLong / fromIntegral n) + +main :: IO () +main = defaultMain [ bench "pipes" $ whnfIO pipeBench + , bench "pipes in-core" $ whnfIO pipeBenchInCore + , bench "pipes in-core subset" $ whnfIO pipeBenchInCore' + , bench "pipes AoS" $ whnfIO pipeBenchAoS ] diff --git a/benchmarks/panda.py b/benchmarks/panda.py new file mode 100644 --- /dev/null +++ b/benchmarks/panda.py @@ -0,0 +1,11 @@ +# Demonstration of streaming data processing. Try building with +# cabal, then running with in bash with something like, +# +# $ /usr/bin/time -l python benchmarks/panda.py 2>&1 | head -n 4 + +from pandas import DataFrame, read_csv +import pandas as pd + +df = pd.read_csv('data/FL2.csv') +print(df['point_latitude'].mean()) +print(df['point_longitude'].mean()) diff --git a/data/GetData.hs b/data/GetData.hs new file mode 100644 --- /dev/null +++ b/data/GetData.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +import Codec.Archive.Zip +import qualified Data.ByteString.Lazy.Char8 as B +import Data.Maybe (fromJust) +import Network.HTTP.Client + +getPrestige :: IO () +getPrestige = withManager defaultManagerSettings $ \m -> + httpLbs req m >>= + B.writeFile "data/prestige.csv" . responseBody + where Just req = parseUrl "http://vincentarelbundock.github.io/Rdatasets/csv/car/Prestige.csv" + +getFLinsurance :: IO () +getFLinsurance = withManager defaultManagerSettings $ \m -> + httpLbs req m >>= + B.writeFile "data/FL2.csv" + . B.map fixup . fromEntry . fromJust + . findEntryByPath "FL_insurance_sample.csv" + . toArchive + . responseBody + where fixup '\r' = '\n' + fixup c = c + Just req = parseUrl "http://spatialkeydocs.s3.amazonaws.com/FL_insurance_sample.csv.zip" + +getAdultIncome :: IO () +getAdultIncome = withManager defaultManagerSettings $ \m -> + httpLbs req m >>= + B.writeFile "data/adult.csv" + . B.append colNames + . responseBody + where Just req = parseUrl "http://archive.ics.uci.edu/ml/machine-learning-databases/adult/adult.data" + colNames = "age, workclass, fnlwgt, education, education-num, \ + \marital-status, occupation, relationship, race, sex, \ + \capital-gain, capital-loss, hours-per-week, \ + \native-country\n" + +main :: IO () +main = do getPrestige + getFLinsurance + getAdultIncome diff --git a/demo/Main.hs b/demo/Main.hs new file mode 100644 --- /dev/null +++ b/demo/Main.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE BangPatterns, DataKinds, TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts, TypeOperators #-} +module Main where +import Data.Functor.Identity +import Frames +import Lens.Family +import qualified ListT as L +import qualified Pipes as P +import qualified Pipes.Prelude as P + +tableTypes "Row" "data/data1.csv" + +listTlist :: Monad m => L.ListT m a -> m [a] +listTlist = L.toList + +tbl :: IO [Row] +tbl = listTlist $ readTable' "data/data1.csv" + +ageDoubler :: (Age ∈ rs) => Record rs -> Record rs +ageDoubler = age *~ 2 + +tbl2 :: IO [Row] +tbl2 = listTlist $ readTable' "data/data2.csv" + +tbl2a :: IO [ColFun Maybe Row] +tbl2a = 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 :: P.Producer Ins IO () +insuranceTbl = readTable "data/FL2.csv" + +insMaybe :: P.Producer (ColFun Maybe Ins) IO () +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+rget 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 + rget pointLongitude r)) 0 id itbl + putStrLn $ "Average longitude: " ++ show (sumLong / fromIntegral n) diff --git a/demo/MissingData.hs b/demo/MissingData.hs new file mode 100644 --- /dev/null +++ b/demo/MissingData.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds, FlexibleInstances, QuasiQuotes, TypeOperators, + UndecidableInstances #-} +-- | An example of dealing with rows that contain missing data. We may +-- want to fill in the gaps with default values. +import Data.Monoid ((<>), First(..)) +import Data.Vinyl (Rec(..), rmap, RecApplicative, rapply) +import Data.Vinyl.Functor (Lift(..)) +import Frames hiding ((:&)) + +-- An en passant Default class +class Default a where + def :: a + +type MyInt = "int" :-> Int +type MyString = "string" :-> String +type MyBool = "bool" :-> Bool + +-- Note that we define instances for column types. This lets us have +-- different defaults for different column names. +instance Default MyInt where def = Col 0 +instance Default MyString where def = Col "" +instance Default MyBool where def = Col False + +-- We can write instances for /all/ 'Rec' values. +instance (Applicative f, LAll Default ts, RecApplicative ts) + => Default (Rec f ts) where + def = reifyDict [pr|Default|] (pure def) + +-- Just to try it out at the 'Identity' functor. +defRec :: Record '[MyString, MyInt, MyBool] +defRec = def + +-- A default record at a more interesting 'Functor'. +defFirst :: Rec First '[MyString, MyInt, MyBool] +defFirst = def + +-- Real data often has holes. Here we have the 'MyString' column, but +-- not the others. +holyRow :: Rec First '[MyString, MyInt, MyBool] +holyRow = rmap First $ pure (Col "joe") :& Nothing :& Nothing :& RNil + +-- We can fill in the holes with our default record. +unholy :: Maybe (Record '[MyString, MyInt, MyBool]) +unholy = recMaybe . rmap getFirst $ rapply (rmap (Lift . flip (<>)) def) holyRow + +main :: IO () +main = return () diff --git a/demo/Plot.hs b/demo/Plot.hs new file mode 100644 --- /dev/null +++ b/demo/Plot.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DataKinds, FlexibleContexts, TemplateHaskell #-} +import qualified Data.Vector.Unboxed as V +import Diagrams.Backend.Rasterific +import Diagrams (dims2D, width, height) +import Frames +import Graphics.Rendering.Chart.Backend.Diagrams (defaultEnv, runBackendR) +import Graphics.Rendering.Chart.Easy +import qualified Pipes as P +import qualified Pipes.Prelude as P +import Statistics.Sample.KernelDensity (kde) + +-- Data from http://wwwn.cdc.gov/nchs/nhanes/2005-2006/TRIGLY_D.htm +tableTypes "Trigly" "data/trigly_d.csv" + +-- Load the data. Invalid records use zeros as a placeholder. +triglyData :: P.Producer Trigly IO () +triglyData = readTable "data/trigly_d.csv" P.>-> P.filter ((> 0) . view lBDLDL) + +-- Adapted from a Chart example +fillBetween :: String -> [(a, (b, b))] -> EC l (PlotFillBetween a b) +fillBetween title vs = liftEC $ do + plot_fillbetween_title .= title + color <- dissolve 0.5 `fmap` takeColor + plot_fillbetween_style .= solidFillStyle color + plot_fillbetween_values .= vs + +-- | Plot a semi-transparent KDE with a thick black outline. +mkPlot :: String -> [Int] -> EC (Layout Double Double) () +mkPlot title xs = do plot (fillBetween title pts) + plot . liftEC $ do + zoom plot_lines_style $ do + line_color .= opaque black + line_width *= 2 + plot_lines_values .= [map (_2 %~ snd) pts] + where pts = V.toList . uncurry (V.zipWith (\x y -> (x, (0, y)))) . kde 128 + $ V.fromList (map fromIntegral xs) + +-- | Plot LDL cholesterol and Triglyceride levels. +mkPlots :: [Record [LBXTR, LBDLDL]] -> EC (Layout Double Double) () +mkPlots xs = do layout_title .= "Distributions" + layout_x_axis . laxis_title .= "mg/dL" + layout_all_font_styles . font_size *= 2 + mkPlot "LDL" ldls + mkPlot "Triglycerides" tris + where ldls = map (view lBDLDL) xs + tris = map (view lBXTR) xs + +main :: IO () +main = do env <- defaultEnv bitmapAlignmentFns 640 480 + let chart2diagram = fst . runBackendR env . toRenderable . execEC + ldlData <- P.toListM $ triglyData P.>-> P.map rcast + let d = chart2diagram $ mkPlots ldlData + sz = dims2D (width d) (height d) + renderRasterific "plot.png" sz d diff --git a/demo/Plot2.hs b/demo/Plot2.hs new file mode 100644 --- /dev/null +++ b/demo/Plot2.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE BangPatterns, DataKinds, FlexibleContexts, OverloadedStrings, + TemplateHaskell #-} +import Diagrams.Backend.Rasterific +import Diagrams (dims2D, width, height) +import Frames +import Graphics.Rendering.Chart.Backend.Diagrams (defaultEnv, runBackendR) +import Graphics.Rendering.Chart.Easy +import Pipes +import qualified Pipes.Prelude as P +import qualified Data.Text as T +import Control.Arrow ((&&&)) +import qualified Data.Foldable as F + +-- Data from http://archive.ics.uci.edu/ml/datasets/Adult +tableTypes "Income" "data/adult.csv" + +adultData :: Producer Income IO () +adultData = readTable "data/adult.csv" + +fishers :: Producer Income IO () +fishers = adultData >-> P.filter isFisher >-> P.filter makesMoney + where isFisher = ((>0) . T.count "fishing" . T.toCaseFold . view occupation) + makesMoney = (> 0) . view capitalGain + +fisherIncomeData :: Producer (Record [Age, CapitalGain]) IO () +fisherIncomeData = fishers >-> P.map rcast + +mkPlot :: IO () +mkPlot = do env <- defaultEnv bitmapAlignmentFns 640 480 + let chart2diagram = fst . runBackendR env . toRenderable . execEC + xs <- P.toListM fisherIncomeData + let d = chart2diagram $ do + layout_title .= "Farmer/fisher Income vs Age" + layout_x_axis . laxis_title .= "Age (Years)" + layout_y_axis . laxis_title .= "Capital Gain ($)" + plot (points "" (map (view age &&& view capitalGain) xs)) + sz = dims2D (width d) (height d) + renderRasterific "plot2.png" sz d + +-- Manually fused folds +main :: IO () +main = do ((age_,inc,n), _) <- P.fold' aux (0,0,0::Double) id fisherIncomeData + putStrLn $ "The average farmer/fisher is "++ + show (fromIntegral age_ / n) ++ + " and made " ++ show (fromIntegral inc / n) + where aux !(!sumAge, !sumIncome, n) f = (sumAge + f^.age, sumIncome + f^.capitalGain, n+1) + +-- Independent folds +maiN :: IO () +maiN = do frames <- inCoreAoS fisherIncomeData + let age_ = F.foldl' ((. view age) . (+)) 0 frames + inc = F.foldl' ((. view capitalGain) . (+)) 0 frames + n = fromIntegral $ frameLength frames :: Double + putStrLn $ "The average farmer/fisher is "++ + show (fromIntegral age_ / n) ++ + " and made " ++ show (fromIntegral inc / n) diff --git a/demo/TutorialMain.hs b/demo/TutorialMain.hs new file mode 100644 --- /dev/null +++ b/demo/TutorialMain.hs @@ -0,0 +1,3 @@ +main :: IO () +main = return () + diff --git a/src/Frames.hs b/src/Frames.hs new file mode 100644 --- /dev/null +++ b/src/Frames.hs @@ -0,0 +1,38 @@ +-- | User-friendly, type safe, runtime efficient tooling for working +-- with tabular data deserialized from comma-separated values (CSV) +-- files. The type of each row of data is inferred from data, which +-- can then be streamed from disk, or worked with in memory. +module Frames + ( module Data.Vinyl + , module Data.Vinyl.Lens + , module Frames.Col + , module Frames.ColumnUniverse + , module Frames.CoRec + , module Frames.CSV + , module Frames.Exploration + , module Frames.Frame + , module Frames.InCore + , module Frames.Melt + , module Frames.Rec + , module Frames.RecF + , module Frames.RecLens + , module Frames.TypeLevel + , Text + ) where +import Data.Text (Text) +import Data.Vinyl ((<+>)) +import Data.Vinyl.Lens hiding (rlens, rget, rput) +import Frames.Col ((:->)(..)) +import Frames.ColumnUniverse +import Frames.CoRec (Field, onField, onCoRec) +import Frames.CSV (readTable, readTableMaybe, readTable', + tableType, tableTypes, tableType', tableTypes') +import Frames.Exploration +import Frames.Frame +import Frames.InCore (toFrame, inCore, inCoreSoA, + inCoreAoS, inCoreAoS', toAoS, filterFrame) +import Frames.Melt (melt, meltRow) +import Frames.Rec (Record, (&:), recUncons, recMaybe, showFields) +import Frames.RecF +import Frames.RecLens +import Frames.TypeLevel diff --git a/src/Frames/CSV.hs b/src/Frames/CSV.hs new file mode 100644 --- /dev/null +++ b/src/Frames/CSV.hs @@ -0,0 +1,407 @@ +{-# LANGUAGE BangPatterns, + DataKinds, + FlexibleInstances, + KindSignatures, + LambdaCase, + MultiParamTypeClasses, + OverloadedStrings, + QuasiQuotes, + RecordWildCards, + ScopedTypeVariables, + TemplateHaskell, + 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.Applicative ((<$>), pure, (<*>)) +import Control.Arrow (first) +import Control.Monad (MonadPlus(..)) +import Control.Monad.IO.Class +import Data.Char (isAlpha, isAlphaNum, toLower, toUpper) +import Data.Foldable (foldMap) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>), Monoid(..)) +import Data.Proxy +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Traversable (sequenceA) +import Data.Vinyl (RElem, Rec) +import Data.Vinyl.TypeLevel (RIndex) +import Frames.Col +import Frames.ColumnTypeable +import Frames.ColumnUniverse +import Frames.Rec +import Frames.RecF +import Frames.RecLens +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import qualified Pipes as P +import System.IO (Handle, hIsEOF, openFile, IOMode(..), withFile) +import Control.Monad (when) +import Data.Maybe (isNothing) +import Control.Monad (void) + +type Separator = T.Text + +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) + +instance Lift QuotingMode where + lift NoQuoting = [|NoQuoting|] + lift (RFC4180Quoting char) = [|RFC4180Quoting $(litE . charL $ char)|] + +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 + +-- | Default 'ParseOptions' get column names from a header line, and +-- use commas to separate columns. +defaultParser :: ParserOptions +defaultParser = ParserOptions Nothing defaultSep (RFC4180Quoting '\"') + +-- | Default separator string. +defaultSep :: Separator +defaultSep = T.pack "," + +-- * Parsing + +-- | 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 + +-- | Post processing applied to a list of tokens split by the +-- separator which should have quoted sections reassembeld +reassembleRFC4180QuotedParts :: Separator -> QuoteChar -> [T.Text] -> [T.Text] +reassembleRFC4180QuotedParts sep quoteChar = finish . foldr f ([], Nothing) + where f :: T.Text -> ([T.Text], Maybe T.Text) -> ([T.Text], Maybe T.Text) + f part (rest, Just accum) + | prefixQuoted part = let token = unescape (T.drop 1 part) <> sep <> accum + in (token : rest, Nothing) + | otherwise = (rest, Just (unescape part <> sep <> accum)) + f part (rest, Nothing) + | prefixQuoted part && + suffixQuoted part = ((unescape . T.drop 1 . T.dropEnd 1 $ part) : rest, Nothing) + | suffixQuoted part = (rest, Just (unescape . T.dropEnd 1 $ part)) + | otherwise = (T.strip part : rest, Nothing) + + prefixQuoted t = + quoteText `T.isPrefixOf` t && + (T.length t - (T.length . T.dropWhile (== quoteChar) $ t)) `mod` 2 == 1 + suffixQuoted t = + quoteText `T.isSuffixOf` t && + (T.length t - (T.length . T.dropWhileEnd (== quoteChar) $ t)) `mod` 2 == 1 + + quoteText = T.singleton quoteChar + + unescape :: T.Text -> T.Text + unescape = T.replace (quoteText <> quoteText) quoteText + + finish :: ([T.Text], Maybe T.Text) -> [T.Text] + finish (rest, Just dangling) = dangling : rest -- FIXME? just assumes the close quote if it's missing + finish (rest, Nothing ) = rest + +--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" +-- | numish txt' -> txt +-- | otherwise -> txt' +-- | otherwise = txt +-- numish = T.all (`elem` ("-+.0123456789"::String)) +-- quoted txt = case T.uncons txt of +-- Just ('"', rst) +-- | not (T.null rst) -> T.last rst == '"' +-- _ -> False + +-- | Infer column types from a prefix (up to 1000 lines) of a CSV +-- file. +prefixInference :: (ColumnTypeable a, Monoid a) + => ParserOptions -> Handle -> IO [a] +prefixInference opts h = T.hGetLine h >>= go prefixSize . inferCols + where prefixSize = 1000 :: Int + inferCols = map inferType . tokenizeRow opts + go 0 ts = return ts + go !n ts = + hIsEOF h >>= \case + True -> return ts + False -> T.hGetLine h >>= go (n - 1) . zipWith (<>) ts . inferCols + +-- | Extract column names and inferred types from a CSV file. +readColHeaders :: (ColumnTypeable a, Monoid a) + => ParserOptions -> FilePath -> IO [(T.Text, a)] +readColHeaders opts f = withFile f ReadMode $ \h -> + zip <$> maybe (tokenizeRow opts <$> T.hGetLine h) + pure + (headerOverride opts) + <*> prefixInference opts h + +-- * Loading 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 Maybe rs + +instance ReadRec '[] where + readRec _ = Nil + +instance (Parseable t, ReadRec ts) => ReadRec (s :-> t ': ts) where + readRec [] = frameCons Nothing (readRec []) + readRec (h:t) = frameCons (parse' h) (readRec t) + +-- | Read a 'RecF' from one line of CSV. +readRow :: ReadRec rs => ParserOptions -> T.Text -> Rec Maybe rs +readRow = (readRec .) . tokenizeRow + +-- | Produce rows where any given entry can fail to parse. +readTableMaybeOpt :: (MonadIO m, ReadRec rs) + => ParserOptions -> FilePath -> P.Producer (Rec Maybe rs) m () +readTableMaybeOpt opts csvFile = + do h <- liftIO $ do + h <- openFile csvFile ReadMode + when (isNothing $ headerOverride opts) (void $ T.hGetLine h) + return h + let go = liftIO (hIsEOF h) >>= \case + True -> return () + False -> liftIO (readRow opts <$> T.hGetLine h) >>= P.yield >> go + go +{-# INLINE readTableMaybeOpt #-} + +-- | Produce rows where any given entry can fail to parse. +readTableMaybe :: (MonadIO m, ReadRec rs) + => FilePath -> P.Producer (Rec Maybe rs) m () +readTableMaybe = readTableMaybeOpt defaultParser +{-# INLINE readTableMaybe #-} + +-- | Returns a `MonadPlus` producer of rows for which each column was +-- successfully parsed. This is typically slower than 'readTableOpt'. +readTableOpt' :: forall m rs. + (MonadPlus m, MonadIO m, ReadRec rs) + => ParserOptions -> FilePath -> m (Record rs) +readTableOpt' opts csvFile = + do h <- liftIO $ do + h <- openFile csvFile ReadMode + when (isNothing $ headerOverride opts) (void $ T.hGetLine h) + return h + let go = liftIO (hIsEOF h) >>= \case + True -> mzero + 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. (MonadPlus m, MonadIO 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 :: forall m rs. + (MonadIO m, ReadRec 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 #-} + +-- | Returns a producer of rows for which each column was successfully +-- parsed. +readTable :: forall m rs. (MonadIO m, ReadRec rs) + => FilePath -> P.Producer (Record rs) m () +readTable = readTableOpt defaultParser +{-# INLINE readTable #-} + +-- * Template Haskell + +-- | Generate a column type. +recDec :: ColumnTypeable a => [(T.Text, a)] -> Q Type +recDec = appT [t|Record|] . go + where go [] = return PromotedNilT + go ((n,t):cs) = + [t|($(litT $ strTyLit (T.unpack n)) :-> $(colType t)) ': $(go cs) |] + +-- | 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) . toTitle' + where valid c = isAlphaNum c || c == '\'' || c == '_' + toTitle' = foldMap (onHead toUpper) . T.split (not . isAlphaNum) + onHead f = maybe mempty (uncurry T.cons) . fmap (first f) . T.uncons + unreserved t + | t `elem` ["Type"] = "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. +mkColTDec :: TypeQ -> Name -> DecQ +mkColTDec colTypeQ colTName = tySynD colTName [] colTypeQ + +-- | Declare a singleton value of the given column type. +mkColPDec :: Name -> TypeQ -> T.Text -> DecsQ +mkColPDec colTName colTy colPName = sequenceA [tySig, val, tySig', val'] + where nm = mkName $ T.unpack colPName + nm' = mkName $ T.unpack colPName <> "'" + -- tySig = sigD nm [t|Proxy $(conT colTName)|] + tySig = sigD nm [t|forall f rs. (Functor f, + RElem $(conT colTName) rs (RIndex $(conT colTName) rs)) + => ($colTy -> f $colTy) + -> Record rs + -> f (Record rs) + |] + tySig' = sigD nm' [t|forall f g rs. (Functor f, Functor g, + RElem $(conT colTName) rs (RIndex $(conT colTName) rs)) + => (g $(conT colTName) -> f (g $(conT colTName))) + -> Rec g rs + -> f (Rec g rs) + |] + val = valD (varP nm) + (normalB [e|rlens (Proxy :: Proxy $(conT colTName))|]) + [] + val' = valD (varP nm') + (normalB [e|rlens' (Proxy :: Proxy $(conT colTName))|]) + [] + +-- | For each column, we declare a type synonym for its type, and a +-- Proxy value of that type. +colDec :: ColumnTypeable a => T.Text -> T.Text -> a -> DecsQ +colDec prefix colName colTy = (:) <$> mkColTDec colTypeQ colTName' + <*> mkColPDec colTName' colTyQ colPName + where colTName = sanitizeTypeName (prefix <> colName) + colPName = fromMaybe "colDec impossible" $ + fmap (\(c,t) -> T.cons (toLower c) t) (T.uncons colTName) + colTName' = mkName $ T.unpack colTName + colTyQ = colType colTy + colTypeQ = [t|$(litT . strTyLit $ T.unpack colName) :-> $colTyQ|] + +-- | Splice for manually declaring a column of a given type. For +-- example, @declareColumn "x2" ''Double@ will declare a type synonym +-- @type X2 = "x2" :-> Double@ and a lens @x2@. +declareColumn :: T.Text -> Name -> DecsQ +declareColumn colName colTy = (:) <$> mkColTDec colTypeQ colTName' + <*> mkColPDec colTName' colTyQ colPName + where colTName = sanitizeTypeName colName + colPName = fromMaybe "colDec impossible" $ + fmap (\(c,t) -> T.cons (toLower c) t) (T.uncons colTName) + colTName' = mkName $ T.unpack colTName + colTyQ = return (ConT colTy) + colTypeQ = [t|$(litT . strTyLit $ T.unpack colName) :-> $colTyQ|] + +-- * Default CSV Parsing + +-- | Control how row and named column types are generated. +data RowGen a = RowGen { columnNames :: [String] + -- ^ Use these column names. If empty, expect a + -- header row in the data file to provide + -- column names. + , tablePrefix :: String + -- ^ A common prefix to use for every generated + -- declaration. + , separator :: Separator + -- ^ The string that separates the columns on a + -- row. + , rowTypeName :: String + -- ^ The row type that enumerates all + -- columns. + , columnUniverse :: Proxy a + -- ^ A type that identifies all the types that + -- can be used to classify a column. This is + -- essentially a type-level list of types. See + -- 'colQ'. + } + +-- | Shorthand for a 'Proxy' value of 'ColumnUniverse' applied to the +-- given type list. +colQ :: Name -> Q Exp +colQ n = [e| (Proxy :: Proxy (ColumnUniverse $(conT n))) |] + +-- | A default 'RowGen'. This instructs the type inference engine to +-- get column names from the data file, use the default column +-- separator (a comma), infer column types from the default 'Columns' +-- set of types, and produce a row type with name @Row@. +rowGen :: RowGen Columns +rowGen = RowGen [] "" defaultSep "Row" Proxy + +-- | 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 = tableType' rowGen { 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 (Proxy :: Proxy +-- Foo)@, and @foo' = rlens' (Proxy :: Proxy Foo)@. +tableTypes :: String -> FilePath -> DecsQ +tableTypes n = tableTypes' rowGen { rowTypeName = n } + +-- * Customized Data Set Parsing + +-- | Generate a type for a row a table. This will be something like +-- @Record ["x" :-> a, "y" :-> b, "z" :-> c]@. Column type synonyms are +-- /not/ generated (see 'tableTypes''). +tableType' :: forall a. (ColumnTypeable a, Monoid a) + => RowGen a -> FilePath -> DecsQ +tableType' (RowGen {..}) csvFile = + pure . TySynD (mkName rowTypeName) [] <$> + (runIO (readColHeaders opts csvFile) >>= recDec') + where recDec' = recDec :: [(T.Text, a)] -> Q Type + colNames' | null columnNames = Nothing + | otherwise = Just (map T.pack columnNames) + opts = ParserOptions colNames' separator (RFC4180Quoting '\"') + +-- | 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 (Proxy :: +-- Proxy Foo)@, and @foo' = rlens' (Proxy :: Proxy Foo)@. +tableTypes' :: forall a. (ColumnTypeable a, Monoid a) + => RowGen a -> FilePath -> DecsQ +tableTypes' (RowGen {..}) csvFile = + do headers <- runIO $ readColHeaders opts csvFile + recTy <- tySynD (mkName rowTypeName) [] (recDec' headers) + let optsName = case rowTypeName of + [] -> error "Row type name shouldn't be empty" + h:t -> mkName $ toLower h : t ++ "Parser" + optsTy <- sigD optsName [t|ParserOptions|] + optsDec <- valD (varP optsName) (normalB $ lift opts) [] + colDecs <- concat <$> mapM (uncurry $ colDec (T.pack tablePrefix)) headers + return (recTy : optsTy : optsDec : colDecs) + -- (:) <$> (tySynD (mkName n) [] (recDec' headers)) + -- <*> (concat <$> mapM (uncurry $ colDec (T.pack prefix)) headers) + where recDec' = recDec :: [(T.Text, a)] -> Q Type + colNames' | null columnNames = Nothing + | otherwise = Just (map T.pack columnNames) + opts = ParserOptions colNames' separator (RFC4180Quoting '\"') diff --git a/src/Frames/CoRec.hs b/src/Frames/CoRec.hs new file mode 100644 --- /dev/null +++ b/src/Frames/CoRec.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE BangPatterns, + ConstraintKinds, + DataKinds, + FlexibleContexts, + FlexibleInstances, + GADTs, + KindSignatures, + MultiParamTypeClasses, + RankNTypes, + ScopedTypeVariables, + TypeOperators, + UndecidableInstances #-} +-- | Co-records: a flexible approach to sum types. +module Frames.CoRec where +import Data.Maybe(fromJust) +import Data.Proxy +import Data.Vinyl +import Data.Vinyl.Functor (Compose(..), (:.), Identity(..)) +import Data.Vinyl.TypeLevel (RIndex) +import Frames.RecF (reifyDict) +import Frames.TypeLevel (LAll, HasInstances, AllHave) +import GHC.Prim (Constraint) + +-- | Generalize algebraic sum types. +data CoRec :: (* -> *) -> [*] -> * where + Col :: RElem a ts (RIndex a ts) => !(f a) -> CoRec f ts + +-- | A Field of a 'Record' is a 'CoRec Identity'. +type Field = CoRec Identity + +-- | Helper to build a 'Show'-able 'CoRec' +col :: (Show a, a ∈ ts) => a -> CoRec (Dict Show) ts +col = Col . Dict + +instance Show (CoRec (Dict Show) ts) where + show (Col (Dict x)) = "Col "++show x + +-- | A function type constructor that takes its arguments in the +-- reverse order. +newtype Op b a = Op { runOp :: a -> b } + +instance forall ts. (LAll Show ts, RecApplicative ts) + => Show (CoRec Identity ts) where + show (Col (Identity x)) = "(Col "++show' x++")" + where shower :: Rec (Op String) ts + shower = reifyDict (Proxy::Proxy Show) (Op show) + show' = runOp (rget Proxy shower) + +-- | Remove a 'Dict' wrapper from a value. +dictId :: Dict c a -> Identity a +dictId (Dict x) = Identity x + +-- | Helper to build a @Dict Show@ +showDict :: Show a => a -> Dict Show a +showDict = Dict + +-- | We can inject a a 'CoRec' into a 'Rec' where every field of the +-- 'Rec' is 'Nothing' except for the one whose type corresponds to the +-- type of the given 'CoRec' variant. +corecToRec :: RecApplicative ts => CoRec f ts -> Rec (Maybe :. f) ts +corecToRec (Col x) = rput (Compose $ Just x) (rpure (Compose Nothing)) + +-- | Shorthand for applying 'corecToRec' with common functors. +corecToRec' :: RecApplicative ts => CoRec Identity ts -> Rec Maybe ts +corecToRec' = rmap (fmap getIdentity . getCompose) . corecToRec + +-- | Fold a field selection function over a 'Rec'. +class FoldRec ss ts where + foldRec :: (CoRec f ss -> CoRec f ss -> CoRec f ss) + -> CoRec f ss + -> Rec f ts + -> CoRec f ss + +instance FoldRec ss '[] where foldRec _ z _ = z + +instance (t ∈ ss, FoldRec ss ts) => FoldRec ss (t ': ts) where + foldRec f z (x :& xs) = foldRec f (f z (Col x)) xs + +-- | Apply a natural transformation to a variant. +corecMap :: (forall x. f x -> g x) -> CoRec f ts -> CoRec g ts +corecMap nt (Col x) = Col (nt x) + +-- | This can be used to pull effects out of a 'CoRec'. +corecTraverse :: Functor h + => (forall x. f x -> h (g x)) -> CoRec f ts -> h (CoRec g ts) +corecTraverse f (Col x) = fmap Col (f x) + +-- | Fold a field selection function over a non-empty 'Rec'. +foldRec1 :: FoldRec (t ': ts) ts + => (CoRec f (t ': ts) -> CoRec f (t ': ts) -> CoRec f (t ': ts)) + -> Rec f (t ': ts) + -> CoRec f (t ': ts) +foldRec1 f (x :& xs) = foldRec f (Col x) xs + +-- | Similar to 'Data.Monoid.First': find the first field that is not +-- 'Nothing'. +firstField :: FoldRec ts ts + => Rec (Maybe :. f) ts -> Maybe (CoRec f ts) +firstField RNil = Nothing +firstField v@(x :& _) = corecTraverse getCompose $ foldRec aux (Col x) v + where aux :: CoRec (Maybe :. f) (t ': ts) + -> CoRec (Maybe :. f) (t ': ts) + -> CoRec (Maybe :. f) (t ': ts) + aux c@(Col (Compose (Just _))) _ = c + aux _ c = c + +-- | Similar to 'Data.Monoid.Last': find the last field that is not +-- 'Nothing'. +lastField :: FoldRec ts ts + => Rec (Maybe :. f) ts -> Maybe (CoRec f ts) +lastField RNil = Nothing +lastField v@(x :& _) = corecTraverse getCompose $ foldRec aux (Col x) v + where aux :: CoRec (Maybe :. f) (t ': ts) + -> CoRec (Maybe :. f) (t ': ts) + -> CoRec (Maybe :. f) (t ': ts) + aux _ c@(Col (Compose (Just _))) = c + aux c _ = c + +-- | Apply a type class method on a 'CoRec'. The first argument is a +-- 'Proxy' value for a /list/ of 'Constraint' constructors. For +-- example, @onCoRec [pr|Num,Ord|] (> 20) r@. If only one constraint +-- is needed, use the @pr1@ quasiquoter. +onCoRec :: forall (cs :: [* -> Constraint]) f ts b. + (AllHave cs ts, Functor f, RecApplicative ts) + => Proxy cs + -> (forall a. HasInstances a cs => a -> b) + -> CoRec f ts -> f b +onCoRec p f (Col x) = fmap meth x + where meth = runOp $ + rget Proxy (reifyDicts p (Op f) :: Rec (Op b) ts) + +-- | Apply a type class method on a 'Field'. The first argument is a +-- 'Proxy' value for a /list/ of 'Constraint' constructors. For +-- example, @onCoRec [pr|Num,Ord|] (> 20) r@. If only one constraint +-- is needed, use the @pr1@ quasiquoter. +onField :: forall cs ts b. + (AllHave cs ts, RecApplicative ts) + => Proxy cs + -> (forall a. HasInstances a cs => a -> b) + -> Field ts -> b +onField p f x = getIdentity (onCoRec p f x) + +-- | Build a record whose elements are derived solely from a +-- list of constraint constructors satisfied by each. +reifyDicts :: forall cs f proxy ts. (AllHave cs ts, RecApplicative ts) + => proxy cs -> (forall a. HasInstances a cs => f a) -> Rec f ts +reifyDicts _ f = go (rpure Nothing) + where go :: AllHave cs ts' => Rec Maybe ts' -> Rec f ts' + go RNil = RNil + go (_ :& xs) = f :& go xs + + + +-- * Extracting values from a CoRec/Pattern matching on a CoRec + +-- | Given a proxy of type t and a 'CoRec Identity' that might be a t, try to +-- convert the CoRec to a t. +asA :: (t ∈ ts, RecApplicative ts) => proxy t -> CoRec Identity ts -> Maybe t +asA p c@(Col _) = rget p $ corecToRec' c + + +-- | Pattern match on a CoRec by specifying handlers for each case. If the +-- CoRec is non-empty this function is total. Note that the order of the +-- Handlers has to match the type level list (t:ts). +-- +-- >>> :{ +-- let testCoRec = Col (Identity False) :: CoRec Identity [Int, String, Bool] in +-- match testCoRec $ +-- (H $ \i -> "my Int is the successor of " ++ show (i - 1)) +-- :& (H $ \s -> "my String is: " ++ s) +-- :& (H $ \b -> "my Bool is not: " ++ show (not b) ++ " thus it is " ++ show b) +-- :& RNil +-- :} +-- "my Bool is not: True thus it is False" +match :: RecApplicative (t ': ts) + => CoRec Identity (t ': ts) -> Handlers (t ': ts) b -> b +match c hs = fromJust $ match' c hs + -- Since we require 'ts' both for the Handlers and the CoRec, Handlers + -- effectively defines a total function. Hence, we can safely use fromJust + +-- | Pattern match on a CoRec by specifying handlers for each case. The only case +-- in which this can produce a Nothing is if the list ts is empty. +match' :: RecApplicative ts => CoRec Identity ts -> Handlers ts b -> Maybe b +match' c hs = match'' hs $ corecToRec' c + where + match'' :: Handlers ts b -> Rec Maybe ts -> Maybe b + match'' RNil RNil = Nothing + match'' (H f :& _) (Just x :& _) = Just $ f x + match'' (H _ :& fs) (Nothing :& c) = match'' fs c + + +-- | Newtype around functions for a to b +newtype Handler b a = H (a -> b) + +-- | 'Handlers ts b', is essentially a list of functions, one for each type in +-- ts. All functions produce a value of type 'b'. Hence, 'Handlers ts b' would +-- represent something like the type-level list: [t -> b | t \in ts ] +type Handlers ts b = Rec (Handler b) ts diff --git a/src/Frames/Col.hs b/src/Frames/Col.hs new file mode 100644 --- /dev/null +++ b/src/Frames/Col.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DataKinds, + GeneralizedNewtypeDeriving, + KindSignatures, + ScopedTypeVariables, + TypeOperators #-} +-- | Column types +module Frames.Col where +import Data.Monoid +import Data.Proxy +import GHC.TypeLits + +-- | A column's type includes a textual name and the data type of each +-- element. +newtype (:->) (s::Symbol) a = Col { getCol :: a } + deriving (Eq,Ord,Num,Monoid,Real,RealFloat,RealFrac,Fractional,Floating) + +instance forall s a. (KnownSymbol s, Show a) => Show (s :-> a) where + show (Col x) = symbolVal (Proxy::Proxy s)++" :-> "++show x + +-- | Used only for a show instance that parenthesizes the value. +newtype Col' s a = Col' (s :-> a) + +-- | Helper for making a 'Col'' +col' :: a -> Col' s a +col' = Col' . Col + +instance (KnownSymbol s, Show a) => Show (Col' s a) where + show (Col' c) = "(" ++ show c ++ ")" diff --git a/src/Frames/ColumnTypeable.hs b/src/Frames/ColumnTypeable.hs new file mode 100644 --- /dev/null +++ b/src/Frames/ColumnTypeable.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE BangPatterns, DefaultSignatures, LambdaCase #-} +module Frames.ColumnTypeable where +import Control.Monad (MonadPlus) +import Data.Readable (Readable(fromText)) +import qualified Data.Text as T +import Language.Haskell.TH + +data Parsed a = Possibly a | Definitely a deriving (Eq, Ord, Show) + +instance Functor Parsed where + fmap f (Possibly x) = Possibly (f x) + fmap f (Definitely x) = Definitely (f x) + +-- | Values that can be read from a 'T.Text' with more or less +-- discrimination. +class Parseable a where + -- | Returns 'Nothing' if a value of the given type can not be read; + -- returns 'Just Possibly' if a value can be read, but is likely + -- ambiguous (e.g. an empty string); returns 'Just Definitely' if a + -- value can be read and is unlikely to be ambiguous." + parse :: (Functor m, MonadPlus m) => T.Text -> m (Parsed a) + default parse :: (Readable a, Functor m, MonadPlus m) + => T.Text -> m (Parsed a) + parse = fmap Definitely . fromText + {-# INLINE parse #-} + +-- | Discard any estimate of a parse's ambiguity. +discardConfidence :: Parsed a -> a +discardConfidence (Possibly x) = x +discardConfidence (Definitely x) = x + +-- | Acts just like 'fromText': tries to parse a value from a 'T.Text' +-- and discards any estimate of the parse's ambiguity. +parse' :: (Functor m, MonadPlus m, Parseable a) => T.Text -> m a +parse' = fmap discardConfidence . parse + +instance Parseable Bool where +instance Parseable Int where +instance Parseable Float where +instance Parseable Double where +instance Parseable T.Text where + +-- | This class relates a universe of possible column types to Haskell +-- types, and provides a mechanism to infer which type best represents +-- some textual data. +class ColumnTypeable a where + colType :: a -> Q Type + inferType :: T.Text -> a diff --git a/src/Frames/ColumnUniverse.hs b/src/Frames/ColumnUniverse.hs new file mode 100644 --- /dev/null +++ b/src/Frames/ColumnUniverse.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE BangPatterns, + ConstraintKinds, + DataKinds, + FlexibleContexts, + FlexibleInstances, + GADTs, + InstanceSigs, + KindSignatures, + LambdaCase, + MultiParamTypeClasses, + OverloadedStrings, + QuasiQuotes, + RankNTypes, + ScopedTypeVariables, + TemplateHaskell, + TypeFamilies, + TypeOperators, + UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Frames.ColumnUniverse (CoRec, Columns, ColumnUniverse, CommonColumns) where +import Language.Haskell.TH +import Data.Monoid +import Data.Proxy +import qualified Data.Text as T +import Data.Typeable (Typeable, showsTypeRep, typeRep) +import Data.Vinyl +import Data.Vinyl.Functor +import Frames.CoRec +import Frames.ColumnTypeable +import Frames.RecF (reifyDict) +import Frames.TypeLevel (LAll) +import Data.Typeable (TypeRep) +import Data.Maybe (fromMaybe) + +-- * TypeRep Helpers + +-- | A 'TypeRep' tagged with the type it is associated with. +type Typed = Const TypeRep + +mkTyped :: forall a. Typeable a => Typed a +mkTyped = Const (typeRep (Proxy::Proxy a)) + +quoteType :: TypeRep -> Q Type +quoteType x = do n <- lookupTypeName s + case n of + Just n' -> conT n' + Nothing -> error $ "Type "++s++" isn't in scope" + where s = showsTypeRep x "" + +-- * Parseable Proxy + +-- | Extract a function to test whether some value of a given type +-- could be read from some 'T.Text'. +inferParseable :: forall a. Parseable a + => T.Text -> (Maybe :. (Parsed :. Proxy)) a +inferParseable = Compose + . fmap (Compose . fmap (const Proxy)) + . (parse :: T.Text -> Maybe (Parsed a)) + +-- | Helper to call 'inferParseable' on variants of a 'CoRec'. +inferParseable' :: Parseable a + => (((->) T.Text) :. (Maybe :. (Parsed :. Proxy))) a +inferParseable' = Compose inferParseable + +-- * Record Helpers + +tryParseAll :: forall ts. (RecApplicative ts, LAll Parseable ts) + => T.Text -> Rec (Maybe :. (Parsed :. Proxy)) ts +tryParseAll = rtraverse getCompose funs + where funs :: Rec (((->) T.Text) :. (Maybe :. (Parsed :. Proxy))) ts + funs = reifyDict (Proxy::Proxy Parseable) inferParseable' + +-- | Preserving the outermost two functor layers, replace each element with +-- its TypeRep. +elementTypes :: (Functor f, Functor g, LAll Typeable ts) + => Rec (f :. (g :. h)) ts -> Rec (f :. (g :. Typed)) ts +elementTypes RNil = RNil +elementTypes (Compose x :& xs) = + Compose (fmap (Compose . fmap (const mkTyped) . getCompose) x) + :& elementTypes xs + +-- * Column Type Inference + +-- | Information necessary for synthesizing row types and comparing +-- types. +newtype ColInfo a = ColInfo (Q Type, Parsed (Typed a)) + +-- | 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@. +lubTypeReps :: Parsed TypeRep -> Parsed TypeRep -> Maybe Ordering +lubTypeReps (Possibly _) (Definitely _) = Just LT +lubTypeReps (Definitely _) (Possibly _) = Just GT +lubTypeReps (Possibly trX) (Possibly trY) + | trX == trY = Just EQ + | otherwise = Nothing +lubTypeReps (Definitely trX) (Definitely trY) + | trX == trY = Just EQ + | trX == trInt && trY == trDbl = Just LT + | trX == trDbl && trY == trInt = Just GT + | trX == trBool && trY == trInt = Just LT + | trX == trInt && trY == trBool = Just GT + | otherwise = Nothing + where trInt = typeRep (Proxy :: Proxy Int) + trDbl = typeRep (Proxy :: Proxy Double) + trBool = typeRep (Proxy :: Proxy Bool) + +instance (T.Text ∈ ts) => Monoid (CoRec ColInfo ts) where + mempty = Col (ColInfo ([t|T.Text|], Possibly mkTyped) :: ColInfo T.Text) + mappend x@(Col (ColInfo (_, trX))) y@(Col (ColInfo (_, trY))) = + case lubTypeReps (fmap getConst trX) (fmap getConst trY) of + Just GT -> x + Just LT -> y + Just EQ -> x + Nothing -> mempty + +-- | Find the best (i.e. smallest) 'CoRec' variant to represent a +-- parsed value. +bestRep :: forall ts. + (LAll Parseable ts, LAll Typeable ts, FoldRec ts ts, + RecApplicative ts, T.Text ∈ ts) + => T.Text -> CoRec ColInfo ts +bestRep = aux + . fromMaybe (Col (Compose $ Possibly (mkTyped :: Typed T.Text))) + . firstField + . elementTypes + . (tryParseAll :: T.Text -> Rec (Maybe :. (Parsed :. Proxy)) ts) + where aux :: CoRec (Parsed :. Typed) ts -> CoRec ColInfo ts + aux (Col (Compose d@(Possibly (Const tr)))) = + Col (ColInfo (quoteType tr, d)) + aux (Col (Compose d@(Definitely (Const tr)))) = + Col (ColInfo (quoteType tr, d)) +{-# INLINABLE bestRep #-} + +instance (LAll Parseable ts, LAll Typeable ts, FoldRec ts ts, + RecApplicative ts, T.Text ∈ ts) => + ColumnTypeable (CoRec ColInfo ts) where + colType (Col (ColInfo (t, _))) = t + {-# INLINE colType #-} + inferType = bestRep + {-# INLINABLE inferType #-} + +-- * Common Columns + +-- | Common column types +type CommonColumns = [Bool, Int, Double, T.Text] + +-- | Define a set of variants that captures all possible column types. +type ColumnUniverse = CoRec ColInfo + +-- | A universe of common column variants. +type Columns = ColumnUniverse CommonColumns diff --git a/src/Frames/Exploration.hs b/src/Frames/Exploration.hs new file mode 100644 --- /dev/null +++ b/src/Frames/Exploration.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, GADTs, TemplateHaskell, + TypeOperators #-} + +-- | Functions useful for interactively exploring and experimenting +-- with a data set. +module Frames.Exploration (pipePreview, select, lenses, recToList, + pr, pr1) where +import Data.Char (isSpace, isUpper) +import Data.Proxy +import qualified Data.Vinyl as V +import Data.Vinyl.Functor (Identity(..)) +import Frames.Rec +import Frames.RecF (AsVinyl(toVinyl), UnColumn) +import Frames.TypeLevel (AllAre) +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Pipes hiding (Proxy) +import qualified Pipes.Prelude as P + +-- * Preview Results + +-- | @preview src n f@ prints out the first @n@ results of piping +-- @src@ through @f@. +pipePreview :: (MonadIO m, Show b) + => Producer a m () -> Int -> Pipe a b m () -> m () +pipePreview src n f = runEffect $ src >-> f >-> P.take n >-> P.print + +-- * Column Selection + +-- | @select (Proxy::Proxy [A,B,C])@ extracts columns @A@, @B@, and +-- @C@, from a larger record. Note, this is just a way of pinning down +-- the type of a usage of 'V.rcast'. +select :: (fs V.⊆ rs) => proxy fs -> Record rs -> Record fs +select _ = V.rcast + +-- | @lenses (Proxy::Proxy [A,B,C])@ provides a lens onto columns @A@, +-- @B@, and @C@. This is just a way of pinning down the type of +-- 'V.rsubset'. +lenses :: (fs V.⊆ rs, Functor f) + => proxy fs -> (Record fs -> f (Record fs)) -> Record rs -> f (Record rs) +lenses _ = V.rsubset + +-- * Proxy Syntax + +-- | A proxy value quasiquoter. @[pr|T|]@ will splice an expression +-- @Proxy::Proxy T@, while @[pr|A,B,C|]@ will splice in a value of +-- @Proxy :: Proxy [A,B,C]@. +pr :: QuasiQuoter +pr = QuasiQuoter mkProxy undefined undefined undefined + where mkProxy s = let ts = map strip $ splitOn ',' s + cons = mapM (conT . mkName) ts + mkList = foldr (AppT . AppT PromotedConsT) PromotedNilT + in case ts of + [h@(t:_)] + | isUpper t -> [|Proxy::Proxy $(fmap head cons)|] + | otherwise -> [|Proxy::Proxy $(varT $ mkName h)|] + _ -> [|Proxy::Proxy $(fmap mkList cons)|] + +-- | Like 'pr', but takes a single type, which is used to produce a +-- 'Proxy' for a single-element list containing only that type. This +-- is useful for passing a single type to a function that wants a list +-- of types. +pr1 :: QuasiQuoter +pr1 = QuasiQuoter mkProxy undefined undefined undefined + where mkProxy s = let sing x = AppT (AppT PromotedConsT x) PromotedNilT + in case s of + t:_ + | isUpper t -> + [|Proxy::Proxy $(fmap sing (conT (mkName s)))|] + | otherwise -> + [|Proxy::Proxy $(fmap sing (varT $ mkName s))|] + _ -> error "Empty string passed to pr1" + +-- * ToList + +recToList :: (AsVinyl rs, AllAre a (UnColumn rs)) => Record rs -> [a] +recToList = go . toVinyl + where go :: AllAre a rs => V.Rec Identity rs -> [a] + go V.RNil = [] + go (Identity x V.:& xs) = x : go xs + +-- * Helpers + +-- | Split on a delimiter. +splitOn :: Eq a => a -> [a] -> [[a]] +splitOn d = go + where go [] = [] + go xs = let (h,t) = break (== d) xs + in case t of + [] -> [h] + (_:t') -> h : go t' + +-- | Remove white space from both ends of a 'String'. +strip :: String -> String +strip = takeWhile (not . isSpace) . dropWhile isSpace diff --git a/src/Frames/Frame.hs b/src/Frames/Frame.hs new file mode 100644 --- /dev/null +++ b/src/Frames/Frame.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE TypeOperators #-} +-- | A 'Frame' is a finite 'Int'-indexed collection of rows. +module Frames.Frame where +import Control.Applicative +import Data.Foldable +import Data.Monoid +import qualified Data.Vector as V +import Data.Vinyl.TypeLevel +import Frames.Rec (Record) +import Frames.RecF (rappend) + +-- | A 'Frame' is a finite collection of rows indexed by 'Int'. +data Frame r = Frame { frameLength :: !Int + , frameRow :: Int -> r } + +-- | A 'Frame' whose rows are 'Record' values. +type FrameRec rs = Frame (Record rs) + +instance Functor Frame where + fmap f (Frame len g) = Frame len (f . g) + +-- | Build a 'Frame' from any 'Foldable'. This simply uses a boxed +-- 'V.Vector' to hold each row. If you have a collection of 'Record's, +-- consider using 'Frames.InCore.toFrame'. +boxedFrame :: Foldable f => f r -> Frame r +boxedFrame xs = Frame (V.length v) (v V.!) + where v = V.fromList (toList xs) + +-- | 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)") + Frame l1 f1 `mappend` Frame l2 f2 = Frame (l1+l2) $ \i -> + if i < l1 then f1 i else f2 i + +instance Foldable Frame where + foldMap f (Frame n row) = foldMap (f . row) [0..n-1] + {-# INLINE foldMap #-} + foldl' f z (Frame n row) = foldl' ((. row) . f) z [0..n-1] + {-# INLINE foldl' #-} + +instance Applicative Frame where + -- | A frame of 'maxBound' rows, each of which is the given value. + pure x = Frame maxBound (const x) + -- | Zips two 'Frame's together, applying the rows of the first to + -- those of the second. The result has as many rows as the smaller + -- of the two argument 'Frame's. + Frame l1 f1 <*> Frame l2 f2 = Frame (min l1 l2) $ ($) <$> f1 <*> f2 + +instance Monad Frame where + -- | A frame of 'maxBound' rows, each of which is the given value. + return = pure + -- | Like 'concatMap' for lists. + Frame l f >>= fb = foldMap (fb . f) [0 .. l - 1] + +-- | Horizontal 'Frame' concatenation. That is, @zipFrames f1 f2@ will +-- return a 'Frame' with as many rows as the smaller of @f1@ and @f2@ +-- whose rows are the result of appending the columns of @f2@ to those +-- of @f1@. +zipFrames :: FrameRec rs -> FrameRec rs' -> FrameRec (rs ++ rs') +zipFrames (Frame l1 f1) (Frame l2 f2) = + Frame (min l1 l2) $ rappend <$> f1 <*> f2 diff --git a/src/Frames/InCore.hs b/src/Frames/InCore.hs new file mode 100644 --- /dev/null +++ b/src/Frames/InCore.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE BangPatterns, + DataKinds, + EmptyCase, + FlexibleInstances, + ScopedTypeVariables, + TupleSections, + TypeFamilies, + TypeOperators, + UndecidableInstances #-} +-- | Efficient in-memory (in-core) storage of tabular data. +module Frames.InCore where +import Control.Applicative +import Control.Monad.Primitive +import Control.Monad.ST (runST) +import Data.Proxy +import Data.Text (Text) +import qualified Data.Vector as VB +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vinyl as V +import Data.Vinyl.Functor (Identity(..)) +import Frames.Col +import Frames.Frame +import Frames.Rec +import Frames.RecF +import GHC.Prim (RealWorld) +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 instance VectorFor Bool = VU.Vector +type instance VectorFor Int = VU.Vector +type instance VectorFor Float = VU.Vector +type instance VectorFor Double = VU.Vector +type instance VectorFor String = VB.Vector +type instance VectorFor Text = VB.Vector + +-- | The mutable version of 'VectorFor' a particular type. +type VectorMFor a = VG.Mutable (VectorFor a) + +-- | Since we stream into the in-memory representation, we use an +-- exponential growth strategy to resize arrays as more data is read +-- in. This is the initial capacity of each column. +initialCapacity :: Int +initialCapacity = 128 + +-- | Mutable vector types for each column in a row. +type family VectorMs m rs where + VectorMs m '[] = '[] + VectorMs m (s :-> a ': rs) = + s :-> VectorMFor a (PrimState m) a ': VectorMs m rs + +-- | Immutable vector types for each column in a row. +type family Vectors rs where + Vectors '[] = '[] + Vectors (s :-> a ': rs) = s :-> VectorFor a a ': Vectors rs + +-- | Tooling to allocate, grow, write to, freeze, and index into +-- records of vectors. +class RecVec rs where + allocRec :: (Applicative m, PrimMonad m) + => proxy rs -> m (Record (VectorMs m rs)) + freezeRec :: (Applicative m, PrimMonad m) + => proxy rs -> Int -> Record (VectorMs m rs) + -> m (Record (Vectors rs)) + growRec :: (Applicative m, PrimMonad m) + => proxy rs -> Record (VectorMs m rs) -> m (Record (VectorMs m rs)) + writeRec :: PrimMonad m + => proxy rs -> Int -> Record (VectorMs m rs) -> Record rs -> m () + indexRec :: proxy rs -> Int -> Record (Vectors rs) -> Record rs + produceRec :: proxy rs -> Record (Vectors rs) -> V.Rec ((->) Int) rs + +-- The use of the type families Vectors and VectorMs interferes with +-- GHC's pattern match exhaustiveness checker, so we write down dummy +-- cases to avoid warnings. This is probably a GHC bug as writing the +-- apparently missing pattern match causes a type checker error! + +instance RecVec '[] where + allocRec _ = return Nil + {-# INLINE allocRec #-} + + freezeRec _ _ V.RNil = return V.RNil + freezeRec _ _ x = case x of + {-# INLINE freezeRec #-} + + growRec _ V.RNil = return V.RNil + growRec _ x = case x of + {-# INLINE growRec #-} + + indexRec _ _ _ = V.RNil + {-# INLINE indexRec #-} + + writeRec _ _ V.RNil V.RNil = return () + writeRec _ _ x _ = case x of + {-# INLINE writeRec #-} + + produceRec _ V.RNil = V.RNil + produceRec _ x = case x of + {-# INLINE produceRec #-} + +instance forall s a rs. + (VGM.MVector (VectorMFor a) a, + VG.Mutable (VectorFor a) ~ VectorMFor a, + VG.Vector (VectorFor a) a, + RecVec rs) + => RecVec (s :-> a ': rs) where + allocRec _ = (&:) <$> VGM.new initialCapacity <*> allocRec (Proxy::Proxy rs) + {-# INLINE allocRec #-} + + freezeRec _ n (Identity (Col x) V.:& xs) = + (&:) <$> (VG.unsafeFreeze $ VGM.unsafeSlice 0 n x) + <*> freezeRec (Proxy::Proxy rs) n xs + freezeRec _ _ x = case x of + {-# INLINE freezeRec #-} + + growRec _ (Identity (Col x) V.:& xs) = (&:) <$> VGM.grow x (VGM.length x) + <*> growRec (Proxy :: Proxy rs) xs + growRec _ x = case x of + {-# INLINE growRec #-} + + writeRec _ !i !(Identity (Col v) V.:& vs) (Identity (Col x) V.:& xs) = + VGM.unsafeWrite v i x >> writeRec (Proxy::Proxy rs) i vs xs + writeRec _ _ _ x = case x of + {-# INLINE writeRec #-} + + indexRec _ !i !(Identity (Col x) V.:& xs) = + x VG.! i &: indexRec (Proxy :: Proxy rs) i xs + indexRec _ _ x = case x of + {-# INLINE indexRec #-} + + produceRec _ (Identity (Col v) V.:& vs) = frameCons (v VG.!) $ + produceRec (Proxy::Proxy rs) vs + produceRec _ x = case x of + {-# INLINE produceRec #-} + +-- | Stream a finite sequence of rows into an efficient in-memory +-- representation for further manipulation. Each column of the input +-- table will be stored optimally based on its type, making use of the +-- resulting generators a matter of indexing into a densely packed +-- representation. Returns the number of rows and a record of column +-- indexing functions. See 'toAoS' to convert the result to a 'Frame' +-- which provides an easier-to-use function that indexes into the +-- table in a row-major fashion. +inCoreSoA :: forall m rs. (Applicative m, PrimMonad m, RecVec rs) + => P.Producer (Record rs) m () -> m (Int, V.Rec ((->) Int) rs) +inCoreSoA xs = + do mvs <- allocRec (Proxy :: Proxy rs) + let feed (!i, !sz, !mvs') row + | i == sz = growRec (Proxy::Proxy rs) mvs' + >>= flip feed row . (i, sz*2,) + | otherwise = do writeRec (Proxy::Proxy rs) i mvs' row + return (i+1, sz, mvs') + fin (n,_,mvs') = + do vs <- freezeRec (Proxy::Proxy rs) n mvs' + return . (n,) $ produceRec (Proxy::Proxy rs) vs + P.foldM feed (return (0,initialCapacity,mvs)) fin xs +{-# INLINE inCoreSoA #-} + +-- | Stream a finite sequence of rows into an efficient in-memory +-- representation for further manipulation. Each column of the input +-- table will be stored optimally based on its type, making use of the +-- resulting generators a matter of indexing into a densely packed +-- representation. Returns a 'Frame' that provides a function to index +-- into the table. +inCoreAoS :: (Applicative m, PrimMonad m, RecVec rs) + => P.Producer (Record rs) m () -> m (FrameRec rs) +inCoreAoS = fmap (uncurry toAoS) . inCoreSoA + +-- | Like 'inCoreAoS', but applies the provided function to the record +-- of columns before building the 'Frame'. +inCoreAoS' :: (Applicative m, PrimMonad m, RecVec rs) + => (V.Rec ((->) Int) rs -> V.Rec ((->) Int) ss) + -> P.Producer (Record rs) m () -> m (FrameRec ss) +inCoreAoS' f = fmap (uncurry toAoS . aux) . inCoreSoA + where aux (x,y) = (x, f y) + +-- | Convert a structure-of-arrays to an array-of-structures. This can +-- simplify usage of an in-memory representation. +toAoS :: Int -> V.Rec ((->) Int) rs -> FrameRec rs +toAoS n = Frame n . rtraverse (fmap Identity) +{-# INLINE toAoS #-} + +-- | Stream a finite sequence of rows into an efficient in-memory +-- representation for further manipulation. Each column of the input +-- table will be stored optimally based on its type, making use of the +-- resulting generator a matter of indexing into a densely packed +-- representation. +inCore :: forall m n rs. (Applicative m, PrimMonad m, RecVec rs, Monad n) + => P.Producer (Record rs) m () -> m (P.Producer (Record rs) n ()) +inCore xs = + do mvs <- allocRec (Proxy :: Proxy rs) + let feed (!i,!sz,!mvs') row + | i == sz = growRec (Proxy::Proxy rs) mvs' + >>= flip feed row . (i, sz*2,) + | otherwise = do writeRec (Proxy::Proxy rs) i mvs' row + return (i+1, sz, mvs') + fin (n,_,mvs') = + do vs <- freezeRec (Proxy::Proxy rs) n mvs' + let spool !i + | i == n = pure () + | otherwise = P.yield (indexRec Proxy i vs) >> spool (i+1) + return $ spool 0 + P.foldM feed (return (0,initialCapacity,mvs)) fin xs +{-# INLINE inCore #-} + +-- | Build a 'Frame' from a collection of 'Record's using efficient +-- column-based storage. +toFrame :: (P.Foldable f, RecVec rs) => f (Record rs) -> Frame (Record rs) +toFrame xs = runST $ inCoreAoS (P.each xs) +{-# INLINE toFrame #-} + +-- | Keep only those rows of a 'FrameRec' that satisfy a predicate. +filterFrame :: RecVec rs => (Record rs -> Bool) -> FrameRec rs -> FrameRec rs +filterFrame p f = runST $ inCoreAoS $ P.each f P.>-> P.filter p +{-# INLINE filterFrame #-} diff --git a/src/Frames/Melt.hs b/src/Frames/Melt.hs new file mode 100644 --- /dev/null +++ b/src/Frames/Melt.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, FlexibleInstances, + KindSignatures, MultiParamTypeClasses, PolyKinds, + ScopedTypeVariables, TypeFamilies, TypeOperators, + UndecidableInstances #-} +module Frames.Melt where +import Data.Proxy +import Data.Vinyl +import Data.Vinyl.Functor (Identity(..)) +import Data.Vinyl.TypeLevel +import Frames.Col +import Frames.CoRec (CoRec) +import qualified Frames.CoRec as C +import Frames.Frame (Frame(..), FrameRec) +import Frames.Rec +import Frames.RecF (ColumnHeaders(..), frameCons) +import Frames.TypeLevel + +type family Elem t ts :: Bool where + Elem t '[] = 'False + Elem t (t ': ts) = 'True + Elem t (s ': ts) = Elem t ts + +type family Or (a :: Bool) (b :: Bool) :: Bool where + Or 'True b = 'True + Or a b = b + +type family Not a :: Bool where + Not 'True = 'False + Not 'False = 'True + +type family Disjoint ss ts :: Bool where + Disjoint '[] ts = 'True + Disjoint (s ': ss) ts = Or (Not (Elem s ts)) (Disjoint ss ts) + +type ElemOf ts r = RElem r ts (RIndex r ts) + +class RowToColumn ts rs where + rowToColumnAux :: Proxy ts -> Rec f rs -> [CoRec f ts] + +instance RowToColumn ts '[] where + rowToColumnAux _ _ = [] + +instance (r ∈ ts, RowToColumn ts rs) => RowToColumn ts (r ': rs) where + rowToColumnAux p (x :& xs) = C.Col x : rowToColumnAux p xs + +-- | Transform a record into a list of its fields, retaining proof +-- that each field is part of the whole. +rowToColumn :: RowToColumn ts ts => Rec f ts -> [CoRec f ts] +rowToColumn = rowToColumnAux Proxy + +meltAux :: forall vs ss ts. + (vs ⊆ ts, ss ⊆ ts, Disjoint ss ts ~ 'True, ts ≅ (vs ++ ss), + ColumnHeaders vs, RowToColumn vs vs) + => Record ts + -> [Record ("value" :-> CoRec Identity vs ': ss)] +meltAux r = map (\val -> frameCons (Identity val) ids) (rowToColumn vals) + where ids = rcast r :: Record ss + vals = rcast r :: Record vs + +type family RDeleteAll ss ts where + RDeleteAll '[] ts = ts + RDeleteAll (s ': ss) ts = RDeleteAll ss (RDelete s ts) + +-- | This is 'melt', but the variables are at the front of the record, +-- which reads a bit odd. +meltRow' :: forall proxy vs ts ss. (vs ⊆ ts, ss ⊆ ts, vs ~ RDeleteAll ss ts, + Disjoint ss ts ~ 'True, ts ≅ (vs ++ ss), + ColumnHeaders vs, RowToColumn vs vs) + => proxy ss + -> Record ts + -> [Record ("value" :-> CoRec Identity vs ': ss)] +meltRow' _ = meltAux + +-- | Turn a cons into a snoc after the fact. +retroSnoc :: forall t ts. Record (t ': ts) -> Record (ts ++ '[t]) +retroSnoc (x :& xs) = go xs + where go :: Record ss -> Record (ss ++ '[t]) + go RNil = x :& RNil + go (y :& ys) = y :& go ys + +-- | Like @melt@ in the @reshape2@ package for the @R@ language. It +-- stacks multiple columns into a single column over multiple +-- rows. Takes a specification of the id columns that remain +-- unchanged. The remaining columns will be stacked. +-- +-- Suppose we have a record, @r :: Record [Name,Age,Weight]@. If we +-- apply @melt [pr1|Name|] r@, we get two values with type @Record +-- [Name, "value" :-> CoRec Identity [Age,Weight]]@. The first will +-- contain @Age@ in the @value@ column, and the second will contain +-- @Weight@ in the @value@ column. +meltRow :: (vs ⊆ ts, ss ⊆ ts, vs ~ RDeleteAll ss ts, + Disjoint ss ts ~ 'True, ts ≅ (vs ++ ss), + ColumnHeaders vs, RowToColumn vs vs) + => proxy ss + -> Record ts + -> [Record (ss ++ '["value" :-> CoRec Identity vs])] +meltRow = (map retroSnoc .) . meltRow' + +class HasLength (ts :: [k]) where + hasLength :: proxy ts -> Int + +instance HasLength '[] where hasLength _ = 0 +instance forall t ts. HasLength ts => HasLength (t ': ts) where + hasLength _ = 1 + hasLength (Proxy :: Proxy ts) + +-- | Applies 'meltRow' to each row of a 'FrameRec'. +melt :: forall vs ts ss proxy. + (vs ⊆ ts, ss ⊆ ts, vs ~ RDeleteAll ss ts, HasLength vs, + Disjoint ss ts ~ 'True, ts ≅ (vs ++ ss), + ColumnHeaders vs, RowToColumn vs vs) + => proxy ss + -> FrameRec ts + -> FrameRec (ss ++ '["value" :-> CoRec Identity vs]) +melt p (Frame n v) = Frame (n*numVs) go + where numVs = hasLength (Proxy :: Proxy vs) + go i = let (j,k) = i `quotRem` numVs + in meltRow p (v j) !! k diff --git a/src/Frames/Rec.hs b/src/Frames/Rec.hs new file mode 100644 --- /dev/null +++ b/src/Frames/Rec.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE ConstraintKinds, + DataKinds, + EmptyCase, + FlexibleContexts, + FlexibleInstances, + FunctionalDependencies, + KindSignatures, + GADTs, + MultiParamTypeClasses, + PatternSynonyms, + PolyKinds, + ScopedTypeVariables, + TypeFamilies, + TypeOperators, + UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Frames.Rec where +import Data.Proxy +import Data.Vinyl (recordToList, rmap, reifyConstraint, Dict(..), Rec) +import Data.Vinyl.TypeLevel (RecAll) +import Data.Vinyl.Functor (Identity(..), Const(..), Compose(..), (:.)) +import Frames.Col +import Frames.RecF + +-- | A record with unadorned values. +type Record = Rec Identity + +-- | A @cons@ function for building 'Record' values. +(&:) :: a -> Record rs -> Record (s :-> a ': rs) +x &: xs = frameCons (Identity x) xs +infixr 5 &: + +-- | Separate the first element of a 'Record' from the rest of the row. +recUncons :: Record (s :-> a ': rs) -> (a, Record rs) +recUncons (Identity x :& xs) = (x, xs) +recUncons x = case x of + +-- | Undistribute 'Maybe' from a 'Rec' 'Maybe'. This is just a +-- specific usage of 'rtraverse', but it is quite common. +recMaybe :: Rec Maybe cs -> Maybe (Record cs) +recMaybe = rtraverse (fmap Identity) +{-# INLINE recMaybe #-} + +-- | Show each field of a 'Record' /without/ its column name. +showFields :: (RecAll Identity (UnColumn ts) Show, AsVinyl ts) + => Record ts -> [String] +showFields = recordToList . rmap aux . reifyConstraint p . toVinyl + where p = Proxy :: Proxy Show + aux :: (Dict Show :. Identity) a -> Const String a + aux (Compose (Dict x)) = Const (show x) +{-# INLINABLE showFields #-} diff --git a/src/Frames/RecF.hs b/src/Frames/RecF.hs new file mode 100644 --- /dev/null +++ b/src/Frames/RecF.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE ConstraintKinds, + DataKinds, + FlexibleContexts, + FlexibleInstances, + GADTs, + KindSignatures, + MultiParamTypeClasses, + PatternSynonyms, + RankNTypes, + ScopedTypeVariables, + TypeFamilies, + TypeOperators, + ViewPatterns #-} +module Frames.RecF (V.rappend, V.rtraverse, rdel, CanDelete, + frameCons, pattern (:&), pattern Nil, AllCols, + UnColumn, AsVinyl(..), mapMono, mapMethod, + ShowRec, showRec, ColFun, ColumnHeaders, + columnHeaders, reifyDict) where +import Control.Applicative ((<$>)) +import Data.List (intercalate) +import Data.Proxy +import qualified Data.Vinyl as V +import Data.Vinyl (Rec(RNil), RecApplicative(rpure)) +import Data.Vinyl.Functor (Identity) +import Data.Vinyl.TypeLevel +import Frames.Col +import Frames.TypeLevel +import GHC.TypeLits (KnownSymbol, symbolVal) + +-- | Add a column to the head of a row. +frameCons :: Functor f => f a -> V.Rec f rs -> V.Rec f (s :-> a ': rs) +frameCons = (V.:&) . fmap Col +{-# INLINE frameCons #-} + +-- | Separate the first element of a row from the rest of the row. +frameUncons :: Functor f => V.Rec f (s :-> r ': rs) -> (f r, V.Rec f rs) +frameUncons (x V.:& xs) = (fmap getCol x, xs) +{-# INLINE frameUncons #-} + +pattern Nil = V.RNil +pattern x :& xs <- (frameUncons -> (x, xs)) + +-- NOTE: A bidirectional pattern synonym would be great, but we'll +-- have to wait for GHC 7.10 to gain wide acceptance before depending +-- upon its availability. + +class ColumnHeaders (cs::[*]) where + -- | Return the column names for a record. + columnHeaders :: proxy (Rec f cs) -> [String] + +instance ColumnHeaders '[] where + columnHeaders _ = [] + +instance forall cs s c. (ColumnHeaders cs, KnownSymbol s) + => ColumnHeaders (s :-> c ': cs) where + columnHeaders _ = symbolVal (Proxy::Proxy s) : columnHeaders (Proxy::Proxy (Rec f cs)) + +-- | A type function to convert a 'Record' to a 'Rec'. @ColFun f (Rec +-- rs) = Rec f rs@. +type family ColFun f x where + ColFun f (Rec Identity rs) = Rec f rs + +-- | Strip the column information from each element of a list of +-- types. +type family UnColumn ts where + UnColumn '[] = '[] + UnColumn ((s :-> t) ': ts) = t ': UnColumn ts + +-- | Enforce a constraint on the payload type of each column. +type AllCols c ts = LAll c (UnColumn ts) + +-- | Remove the column name phantom types from a record, leaving you +-- with an unadorned Vinyl 'V.Rec'. +class AsVinyl ts where + toVinyl :: Functor f => Rec f ts -> V.Rec f (UnColumn ts) + fromVinyl :: Functor f => V.Rec f (UnColumn ts) -> Rec f ts + +instance AsVinyl '[] where + toVinyl _ = V.RNil + fromVinyl _ = V.RNil + +instance AsVinyl ts => AsVinyl (s :-> t ': ts) where + toVinyl (x V.:& xs) = fmap getCol x V.:& toVinyl xs + fromVinyl (x V.:& xs) = fmap Col x V.:& fromVinyl xs + fromVinyl _ = error "GHC coverage checker isn't great" + +-- | Map a function across a homogeneous, monomorphic 'V.Rec'. +mapMonoV :: (Functor f, AllAre a ts) => (a -> a) -> V.Rec f ts -> V.Rec f ts +mapMonoV _ V.RNil = V.RNil +mapMonoV f (x V.:& xs) = fmap f x V.:& mapMonoV f xs + +-- | Map a function across a homogeneous, monomorphic 'Rec'. +mapMono :: (AllAre a (UnColumn ts), Functor f, AsVinyl ts) + => (a -> a) -> Rec f ts -> Rec f ts +mapMono f = fromVinyl . mapMonoV f . toVinyl + +-- | Map a typeclass method across a 'V.Rec' each of whose fields +-- have instances of the typeclass. +mapMethodV :: forall c f ts. (Functor f, LAll c ts) + => Proxy c -> (forall a. c a => a -> a) -> V.Rec f ts -> V.Rec f ts +mapMethodV _ f = go + where go :: LAll c ts' => V.Rec f ts' -> V.Rec f ts' + go V.RNil = V.RNil + go (x V.:& xs) = fmap f x V.:& go xs + +-- | Map a typeclass method across a 'Rec' each of whose fields +-- has an instance of the typeclass. +mapMethod :: forall f c ts. (Functor f, LAll c (UnColumn ts), AsVinyl ts) + => Proxy c -> (forall a. c a => a -> a) -> Rec f ts -> Rec f ts +mapMethod p f = fromVinyl . mapMethodV p f . toVinyl + +-- | A constraint that a field can be deleted from a record. +type CanDelete r rs = (V.RElem r rs (RIndex r rs), RDelete r rs V.⊆ rs) + +-- | Delete a field from a record +rdel :: CanDelete r rs => proxy r -> Rec f rs -> Rec f (RDelete r rs) +rdel _ = V.rcast + +-- | The ability to pretty print a 'Rec''s fields. +class Functor f => ShowRec f rs where + showRec' :: Rec f rs -> [String] + +instance Functor f => ShowRec f '[] where + showRec' _ = [] + +instance forall s f a rs. (KnownSymbol s, Show (f (Col' s a)), ShowRec f rs) + => ShowRec f (s :-> a ': rs) where + showRec' (x :& xs) = show (col' <$> x :: f (Col' s a)) : showRec' xs + showRec' _ = error "GHC coverage error" + +-- | Pretty printing of 'Rec' values. +showRec :: ShowRec f rs => Rec f rs -> String +showRec r = "{" ++ intercalate ", " (showRec' r) ++ "}" + +-- | Build a record whose elements are derived solely from a +-- constraint satisfied by each. +reifyDict :: forall c f proxy ts. (LAll c ts, RecApplicative ts) + => proxy c -> (forall a. c a => f a) -> Rec f ts +reifyDict _ f = go (rpure Nothing) + where go :: LAll c ts' => Rec Maybe ts' -> Rec f ts' + go RNil = RNil + go (_ V.:& xs) = f V.:& go xs diff --git a/src/Frames/RecLens.hs b/src/Frames/RecLens.hs new file mode 100644 --- /dev/null +++ b/src/Frames/RecLens.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE ConstraintKinds, + DataKinds, + FlexibleContexts, + FlexibleInstances, + MultiParamTypeClasses, + RankNTypes, + ScopedTypeVariables, + TypeFamilies, + TypeOperators #-} +-- | Lens utilities for working with 'Record's. +module Frames.RecLens where +import Control.Applicative +import qualified Data.Vinyl as V +import Data.Vinyl.Functor (Identity(..)) +import Data.Vinyl.TypeLevel +import Frames.Col ((:->)(..)) +import Frames.Rec (Record) + +rlens' :: (i ~ RIndex r rs, V.RElem r rs i, Functor f, Functor g) + => sing r + -> (g r -> f (g r)) + -> V.Rec g rs + -> f (V.Rec g rs) +rlens' = V.rlens +{-# INLINE rlens' #-} + +-- | Getter for a 'V.Rec' field +rget' :: Functor g + => (forall f. Functor f + => (g (s :-> a) -> f (g (s :-> a))) -> V.Rec g rs -> f (V.Rec g rs)) + -> V.Rec g rs -> g a +rget' l = fmap getCol . getConst . l Const +{-# INLINE rget' #-} + +-- | Setter for a 'V.Rec' field. +rput' :: Functor g + => (forall f. Functor f + => (g (s :-> a) -> f (g (s :-> a))) -> V.Rec g rs -> f (V.Rec g rs)) + -> g a -> V.Rec g rs -> V.Rec g rs +rput' l y = getIdentity . l (\_ -> Identity (fmap Col y)) +{-# INLINE rput' #-} + +-- * Plain records + +-- | Create a lens for accessing a field of a 'Record'. +rlens :: (Functor f, V.RElem (s :-> a) rs (RIndex (s :-> a) rs)) + => proxy (s :-> a) -> (a -> f a) -> Record rs -> f (Record rs) +rlens k f = rlens' k (fmap Identity . getIdentity . fmap f') + where f' (Col x) = fmap Col (f x) +{-# INLINE rlens #-} + +-- | Getter for a 'Record' field. +rget :: (forall f. Functor f => (a -> f a) -> Record rs -> f (Record rs)) + -> Record rs -> a +rget l = getConst . l Const +{-# INLINE rget #-} + +-- | Setter for a 'Record' field. +rput :: (forall f. Functor f => (a -> f a) -> Record rs -> f (Record rs)) + -> a -> Record rs -> Record rs +rput l y = getIdentity . l (\_ -> Identity y) +{-# INLINE rput #-} diff --git a/src/Frames/TypeLevel.hs b/src/Frames/TypeLevel.hs new file mode 100644 --- /dev/null +++ b/src/Frames/TypeLevel.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators #-} +-- | Helpers for working with type-level lists. +module Frames.TypeLevel where +import GHC.Prim (Constraint) + +-- | Remove the first occurence of a type from a type-level list. +type family RDelete r rs where + RDelete r (r ': rs) = rs + RDelete r (s ': rs) = s ': RDelete r rs + +-- | A constraint on each element of a type-level list. +type family LAll c ts :: Constraint where + LAll c '[] = () + LAll c (t ': ts) = (c t, LAll c ts) + +-- | Constraint that every element of a promoted list is equal to a +-- particular type. That is, the list of types is a single type +-- repeated some number of times. +type family AllAre a ts :: Constraint where + AllAre a '[] = () + AllAre a (t ': ts) = (t ~ a, AllAre a ts) + +-- | Compound constraint that a type has an instance for each of a +-- list of type classes. +type family HasInstances a cs :: Constraint where + HasInstances a '[] = () + HasInstances a (c ': cs) = (c a, HasInstances a cs) + +-- | Compound constraint that all types have instances for each of a +-- list of type clasesses. @AllHave classes types@. +type family AllHave cs as :: Constraint where + AllHave cs '[] = () + AllHave cs (a ': as) = (HasInstances a cs, AllHave cs as) +