Frames 0.1.9 → 0.2.0

raw patch · 17 files changed

+187/−339 lines, 17 filesdep +HUnitdep ~basedep ~diagrams-libdep ~diagrams-rasterificPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit

Dependency ranges changed: base, diagrams-lib, diagrams-rasterific, pipes, vinyl

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• Frames.cabal +15/−9
• demo/Kata04.hs +1/−0
• demo/MissingData.hs +1/−1
• src/Frames.hs +4/−2
• src/Frames/CSV.hs +47/−21
• src/Frames/CoRec.hs +0/−228
• src/Frames/ColumnTypeable.hs +2/−1
• src/Frames/ColumnUniverse.hs +21/−18
• src/Frames/Frame.hs +4/−0
• src/Frames/Melt.hs +3/−5
• src/Frames/RecF.hs +10/−9
• src/Frames/RecLens.hs +1/−1
• src/Frames/TypeLevel.hs +0/−23
• test/DataCSV.hs +0/−10
• test/Mpg.hs +21/−0
• test/Spec.hs +51/−11

@@ -1,3 +1,9 @@+# 0.1.10++- Added CSV output functions: `produceCSV` and `writeCSV`+- Added an Eq instance for the `Frame` type++ # 0.1.9  Fixed column type inference bug that led the inferencer to prefer `Bool` too strongly.

@@ -1,5 +1,5 @@ name:                Frames-version:             0.1.9+version:             0.2.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@@ -36,7 +36,6 @@                        Frames.Col                        Frames.ColumnTypeable                        Frames.ColumnUniverse-                       Frames.CoRec                        Frames.CSV                        Frames.Exploration                        Frames.Frame@@ -50,7 +49,7 @@                        TypeOperators, ConstraintKinds, StandaloneDeriving,                        UndecidableInstances, ScopedTypeVariables,                        OverloadedStrings-  build-depends:       base >=4.8 && <4.10,+  build-depends:       base >=4.8 && <4.11,                        ghc-prim >=0.3 && <0.6,                        primitive >= 0.6 && < 0.7,                        text >= 1.1.1.0,@@ -59,7 +58,7 @@                        vector,                        readable >= 0.3.1,                        pipes >= 4.1 && < 5,-                       vinyl >= 0.5 && < 0.6+                       vinyl >= 0.6 && < 0.7   hs-source-dirs:      src   default-language:    Haskell2010   ghc-options:         -Wall@@ -87,8 +86,8 @@                    pipes >= 4.1.5 && < 4.4,                    Chart >= 1.5 && < 1.9,                    Chart-diagrams >= 1.5 && < 1.9,-                   diagrams-rasterific >= 1.3 && < 1.4,-                   diagrams-lib >= 1.3 && < 1.4,+                   diagrams-rasterific >= 1.3 && < 1.5,+                   diagrams-lib >= 1.3 && < 1.5,                    readable, containers, statistics   hs-source-dirs: demo   default-language: Haskell2010@@ -103,8 +102,8 @@                    pipes >= 4.1.5 && < 4.4,                    Chart >= 1.5 && < 1.9,                    Chart-diagrams >= 1.5 && < 1.9,-                   diagrams-rasterific >= 1.3 && < 1.4,-                   diagrams-lib >= 1.3 && < 1.4,+                   diagrams-rasterific >= 1.3 && < 1.5,+                   diagrams-lib >= 1.3 && < 1.5,                    readable, containers, statistics   hs-source-dirs: demo   default-language: Haskell2010@@ -189,7 +188,7 @@   other-modules:       DataCSV PrettyTH Temp   build-depends:       base, text, hspec, Frames, template-haskell,                        temporary, directory, htoml, regex-applicative, pretty,-                       unordered-containers+                       unordered-containers, pipes, HUnit   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall   default-language:    Haskell2010 @@ -197,5 +196,12 @@   type:                exitcode-stdio-1.0   hs-source-dirs:      test   main-is:             Overlap.hs+  build-depends:       base, Frames+  default-language:    Haskell2010++test-suite mpg+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Mpg.hs   build-depends:       base, Frames   default-language:    Haskell2010

@@ -15,6 +15,7 @@ -- Data set from http://codekata.com/data/04/weather.dat -- Associated with this problem set: -- http://codekata.com/kata/kata04-data-munging/+-- Asterisk suffixes were manually removed from temperature columns. tableTypes "Row" "data/weather.csv"  getTemperatureRange :: (MxT ∈ rs, MnT ∈ rs) => Record rs -> Double

@@ -25,7 +25,7 @@ instance Default MyBool where def = Col False  -- We can write instances for /all/ 'Rec' values.-instance (Applicative f, LAll Default ts, RecApplicative ts)+instance (Applicative f, AllConstrained Default ts, RecApplicative ts)   => Default (Rec f ts) where   def = reifyDict [pr|Default|] (pure def) 

@@ -4,10 +4,11 @@ -- can then be streamed from disk, or worked with in memory. module Frames   ( module Data.Vinyl+  , module Data.Vinyl.CoRec   , module Data.Vinyl.Lens+  , module Data.Vinyl.TypeLevel   , module Frames.Col   , module Frames.ColumnUniverse-  , module Frames.CoRec   , module Frames.CSV   , module Frames.Exploration   , module Frames.Frame@@ -21,10 +22,11 @@   ) where import Data.Text (Text) import Data.Vinyl ((<+>))+import Data.Vinyl.CoRec (Field, onField, onCoRec) import Data.Vinyl.Lens hiding (rlens, rget, rput)+import Data.Vinyl.TypeLevel (AllConstrained, AllSatisfied, AllAllSat) import Frames.Col ((:->)(..)) import Frames.ColumnUniverse-import Frames.CoRec (Field, onField, onCoRec) import Frames.CSV (readTable, readTableMaybe, readTable', declareColumn,                    tableType, tableTypes, tableType', tableTypes') import Frames.Exploration

@@ -27,13 +27,16 @@ import Control.Monad (MonadPlus(..), when, void) import Control.Monad.IO.Class import Data.Char (isAlpha, isAlphaNum, toLower, toUpper)+import qualified Data.Foldable as F+import Data.List (intercalate) import Data.Maybe (isNothing, fromMaybe) import Data.Monoid ((<>)) import Data.Proxy import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Vinyl (RElem, Rec)-import Data.Vinyl.TypeLevel (RIndex)+import Data.Vinyl.TypeLevel (RecAll, RIndex)+import Data.Vinyl.Functor (Identity) import Frames.Col import Frames.ColumnTypeable import Frames.ColumnUniverse@@ -43,6 +46,7 @@ import Language.Haskell.TH import Language.Haskell.TH.Syntax import qualified Pipes as P+import qualified Pipes.Prelude as P import System.IO (Handle, hIsEOF, openFile, IOMode(..), withFile)  type Separator = T.Text@@ -100,33 +104,35 @@ -- | 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)+reassembleRFC4180QuotedParts sep quoteChar = go+  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 =-          quoteText `T.isPrefixOf` t &&-          (T.length t - (T.length . T.dropWhile (== quoteChar) $ t)) `mod` 2 == 1+          T.head t == quoteChar &&+          T.length (T.takeWhile (== quoteChar) t) `rem` 2 == 1+         suffixQuoted t =           quoteText `T.isSuffixOf` t &&-          (T.length t - (T.length . T.dropWhileEnd (== quoteChar) $ t)) `mod` 2 == 1+          T.length (T.takeWhileEnd (== quoteChar) t) `rem` 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+        unescape = T.replace q2 quoteText+          where q2 = quoteText <> quoteText  --tokenizeRow :: Separator -> T.Text -> [T.Text] --tokenizeRow sep = map (unquote . T.strip) . T.splitOn sep@@ -260,7 +266,7 @@         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+          | t `elem` ["Type", "Class"] = "Col" <> t           | otherwise = t         fixupStart t = case T.uncons t of                          Nothing -> "Col"@@ -441,3 +447,23 @@           case mColNm of             Just _ -> pure []             Nothing -> colDec (T.pack tablePrefix) colNm colTy++-- * Writing CSV Data++-- | 'P.yield' a header row with column names followed by a line of+-- text for each 'Record' with each field separated by a comma.+produceCSV :: forall f ts m.+              (ColumnHeaders ts, AsVinyl ts, Foldable f, Monad m,+               RecAll Identity (UnColumn ts) Show)+           => f (Record ts) -> P.Producer String m ()+produceCSV recs = do+  P.yield (intercalate "," (columnHeaders (Proxy :: Proxy (Record ts))))+  F.mapM_ (P.yield . intercalate "," . showFields) recs++-- | Write a header row with column names followed by a line of text+-- for each 'Record' to the given file.+writeCSV :: (ColumnHeaders ts, AsVinyl ts, Foldable f,+             RecAll Identity (UnColumn ts) Show)+         => FilePath -> f (Record ts) -> IO ()+writeCSV fp recs = withFile fp WriteMode $ \h ->+                     P.runEffect $ produceCSV recs P.>-> P.toHandle h

@@ -1,228 +0,0 @@-{-# LANGUAGE BangPatterns,-             ConstraintKinds,-             CPP,-             DataKinds,-             FlexibleContexts,-             FlexibleInstances,-             GADTs,-             KindSignatures,-             MultiParamTypeClasses,-             RankNTypes,-             ScopedTypeVariables,-             TypeOperators,-             UndecidableInstances #-}--- | Co-records: a flexible approach to sum types. 'Frames.Melt.melt'--- is a good example of how such a facility is useful in @Frames@--- usage scenarios.------ Consider a record with three fields @A@, @B@, and @C@. A record is--- a product of its fields; that is, it contains all of them: @A@,--- @B@, /and/ @C@. If we want to talk about a value whose type is one--- of those three types, it is /any one/ of type @A@, @B@, /or/--- @C@. The type @CoRec '[A,B,C]@ corresponds to this sum type.-module Frames.CoRec where-import Data.Maybe(fromJust)-import Data.Proxy-import Data.Vinyl-import Data.Vinyl.Functor (Compose(..), (:.), Identity(..), Const(..))-import Data.Vinyl.TypeLevel (RIndex, RecAll)-import Frames.RecF (reifyDict)-import Frames.TypeLevel (LAll, HasInstances, AllHave)-#if __GLASGOW_HASKELL__ < 800-import GHC.Prim (Constraint)-#else-import Data.Kind (Constraint)-#endif---- | Generalize algebraic sum types.-data CoRec :: (* -> *) -> [*] -> * where-  Col :: RElem a ts (RIndex a ts) => !(f a) -> CoRec f ts--foldCoRec :: (forall a. RElem a ts (RIndex a ts) => f a -> b) -> CoRec f ts -> b-foldCoRec f (Col x) = f x---- | 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)--instance forall ts. (RecAll Maybe ts Eq, RecApplicative ts)-  => Eq (CoRec Identity ts) where-  crA == crB = and . recordToList-             $ zipRecsWith f (toRec crA) (corecToRec' crB)-    where-      f :: forall a. (Dict Eq :. Maybe) a -> Maybe a -> Const Bool a-      f (Compose (Dict a)) b = Const $ a == b-      toRec = reifyConstraint (Proxy :: Proxy Eq) . corecToRec'---- | 'zipWith' for Rec's.-zipRecsWith :: (forall a. f a -> g a -> h a) -> Rec f as -> Rec g as -> Rec h as-zipRecsWith _ RNil      _         = RNil-zipRecsWith f (r :& rs) (s :& ss) = f r s :& zipRecsWith f rs ss---- | 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

@@ -38,7 +38,8 @@ instance Parseable Int where instance Parseable Float where instance Parseable Double where-  -- Some CSV's export Doubles in a format like '1,000.00', filtering out commas lets us parse those sucessfully+  -- Some CSV's export Doubles in a format like '1,000.00', filtering+  -- out commas lets us parse those sucessfully   parse = fmap Definitely . fromText . T.filter (/= ',') instance Parseable T.Text where 

@@ -18,7 +18,7 @@              TypeOperators,              UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-module Frames.ColumnUniverse (CoRec, Columns, ColumnUniverse, CommonColumns, +module Frames.ColumnUniverse (CoRec, Columns, ColumnUniverse, CommonColumns,                               parsedTypeRep) where import Language.Haskell.TH #if __GLASGOW_HASKELL__ < 800@@ -28,11 +28,11 @@ import qualified Data.Text as T import Data.Typeable (Typeable, showsTypeRep, typeRep) import Data.Vinyl+import Data.Vinyl.CoRec import Data.Vinyl.Functor-import Frames.CoRec+import Data.Vinyl.TypeLevel (AllConstrained) import Frames.ColumnTypeable import Frames.RecF (reifyDict)-import Frames.TypeLevel (LAll) import Data.Typeable (TypeRep) import Data.Maybe (fromMaybe) @@ -68,7 +68,7 @@  -- * Record Helpers -tryParseAll :: forall ts. (RecApplicative ts, LAll Parseable ts)+tryParseAll :: forall ts. (RecApplicative ts, AllConstrained Parseable ts)             => T.Text -> Rec (Maybe :. (Parsed :. Proxy)) ts tryParseAll = rtraverse getCompose funs   where funs :: Rec (((->) T.Text) :. (Maybe :. (Parsed :. Proxy))) ts@@ -76,7 +76,7 @@  -- | Preserving the outermost two functor layers, replace each element with -- its TypeRep.-elementTypes :: (Functor f, Functor g, LAll Typeable ts)+elementTypes :: (Functor f, Functor g, AllConstrained Typeable ts)              => Rec (f :. (g :. h)) ts -> Rec (f :. (g :. Typed)) ts elementTypes RNil = RNil elementTypes (Compose x :& xs) =@@ -113,6 +113,8 @@   | otherwise = Nothing lubTypeReps (Definitely trX) (Definitely trY)   | trX == trY = Just EQ+  | trX == trText = Just GT+  | trY == trText = Just LT   | trX == trInt  && trY == trDbl = Just LT   | trX == trDbl  && trY == trInt = Just GT   | trX == trBool && trY == trInt = Just LT@@ -123,10 +125,11 @@   where trInt = typeRep (Proxy :: Proxy Int)         trDbl = typeRep (Proxy :: Proxy Double)         trBool = typeRep (Proxy :: Proxy Bool)+        trText = typeRep (Proxy :: Proxy T.Text)  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))) =+  mempty = CoRec (ColInfo ([t|T.Text|], Possibly mkTyped) :: ColInfo T.Text)+  mappend x@(CoRec (ColInfo (_, trX))) y@(CoRec (ColInfo (_, trY))) =       case lubTypeReps (fmap getConst trX) (fmap getConst trY) of         Just GT -> x         Just LT -> y@@ -136,35 +139,35 @@ -- | Find the best (i.e. smallest) 'CoRec' variant to represent a -- parsed value. For inspection in GHCi after loading this module, -- consider this example:--- +-- -- >>> :set -XTypeApplications -- >>> :set -XOverloadedStrings--- >>> import Frames.CoRec (foldCoRec)+-- >>> import Data.Vinyl.CoRec (foldCoRec) -- >>> foldCoRec parsedTypeRep (bestRep @CommonColumns "2.3") -- Definitely Double bestRep :: forall ts.-           (LAll Parseable ts, LAll Typeable ts, FoldRec ts ts,+           (AllConstrained Parseable ts, AllConstrained Typeable ts, FoldRec ts ts,             RecApplicative ts, T.Text ∈ ts)         => T.Text -> CoRec ColInfo ts bestRep t-  | T.null t = aux (Col (Compose (Possibly (mkTyped :: Typed T.Text))))+  | T.null t = aux (CoRec (Compose (Possibly (mkTyped :: Typed T.Text))))   | otherwise = aux-              . fromMaybe (Col (Compose $ Possibly (mkTyped :: Typed T.Text)))+              . fromMaybe (CoRec (Compose $ Possibly (mkTyped :: Typed T.Text)))               . firstField               . elementTypes               . (tryParseAll :: T.Text -> Rec (Maybe :. (Parsed :. Proxy)) ts)               $ t   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))+        aux (CoRec (Compose d@(Possibly (Const tr)))) =+          CoRec (ColInfo (quoteType tr, d))+        aux (CoRec (Compose d@(Definitely (Const tr)))) =+          CoRec (ColInfo (quoteType tr, d)) {-# INLINABLE bestRep #-} -instance (LAll Parseable ts, LAll Typeable ts, FoldRec ts ts,+instance (AllConstrained Parseable ts, AllConstrained Typeable ts, FoldRec ts ts,           RecApplicative ts, T.Text ∈ ts) =>     ColumnTypeable (CoRec ColInfo ts) where-  colType (Col (ColInfo (t, _))) = t+  colType (CoRec (ColInfo (t, _))) = t   {-# INLINE colType #-}   inferType = bestRep   {-# INLINABLE inferType #-}

@@ -27,6 +27,10 @@ boxedFrame xs = Frame (V.length v) (v V.!)   where v = V.fromList (toList xs) +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])+ -- | 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@.

@@ -5,15 +5,13 @@ module Frames.Melt where import Data.Proxy import Data.Vinyl+import Data.Vinyl.CoRec (CoRec(..)) 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@@ -41,7 +39,7 @@   rowToColumnAux _ _ = []  instance (r ∈ ts, RowToColumn ts rs) => RowToColumn ts (r ': rs) where-  rowToColumnAux p (x :& xs) = C.Col x : rowToColumnAux p xs+  rowToColumnAux p (x :& xs) = CoRec x : rowToColumnAux p xs  -- | Transform a record into a list of its fields, retaining proof -- that each field is part of the whole.@@ -106,7 +104,7 @@ -- | 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), +         Disjoint ss ts ~ 'True, ts ≅ (vs ++ ss),          ColumnHeaders vs, RowToColumn vs vs)      => proxy ss      -> FrameRec ts

@@ -16,7 +16,7 @@                     frameCons, frameConsA, frameSnoc,                     pattern (:&), pattern Nil, AllCols,                     UnColumn, AsVinyl(..), mapMono, mapMethod,-                    ShowRec, showRec, ColFun, ColumnHeaders, +                    ShowRec, showRec, ColFun, ColumnHeaders,                     columnHeaders, reifyDict) where import Data.List (intercalate) import Data.Proxy@@ -49,10 +49,10 @@ frameSnoc r x = V.rappend r (x V.:& RNil) {-# INLINE frameSnoc #-} --- Nil :: Rec f '[]+pattern Nil :: Rec f '[] pattern Nil = V.RNil --- (:&) :: Functor f => f r -> Rec f rs -> Rec f (r ': rs)+pattern (:&) :: Functor f => f r -> Rec f rs -> Rec f (s :-> r ': rs) pattern x :& xs <- (frameUncons -> (x, xs))  -- NOTE: A bidirectional pattern synonym would be great, but we'll@@ -82,7 +82,7 @@   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)+type AllCols c ts = AllConstrained c (UnColumn ts)  -- | Remove the column name phantom types from a record, leaving you -- with an unadorned Vinyl 'V.Rec'.@@ -113,16 +113,17 @@  -- | 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)+mapMethodV :: forall c f ts. (Functor f, AllConstrained 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'+  where go :: AllConstrained 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)+mapMethod :: forall f c ts.+             (Functor f, AllConstrained 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 @@ -151,9 +152,9 @@  -- | 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)+reifyDict :: forall c f proxy ts. (AllConstrained 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'+  where go :: AllConstrained c ts' => Rec Maybe ts' -> Rec f ts'         go RNil = RNil         go (_ V.:& xs) = f V.:& go xs

@@ -16,7 +16,7 @@ import Frames.Col ((:->)(..)) import Frames.Rec (Record) -rlens' :: (i ~ RIndex r rs, V.RElem r rs i, Functor f, Functor g)+rlens' :: (i ~ RIndex r rs, V.RElem r rs i, Functor f)        => sing r        -> (g r -> f (g r))        -> V.Rec g rs

@@ -7,32 +7,9 @@ import Data.Kind (Constraint) #endif --- | 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)-  

@@ -10,16 +10,6 @@ import Text.Toml import Text.Toml.Types (Node (VTable, VString), Table) -managersCsv :: [Char]-managersCsv = "id,manager,age,pay\n\-               \0,Joe,53,\"80,000\"\n\-               \1,Sarah,44,\"80,000\""--employeesCsv :: [Char]-employeesCsv = "id,employee,age,pay,manager_id\n\-                \2,Sadie,28,\"40,000\",0\n\-                \3,Tom,25,\"40,000\",1"- data CsvExample = CsvExample { name :: String, csv :: String, generated :: String }  instance Lift CsvExample where

@@ -0,0 +1,21 @@+{-# LANGUAGE DataKinds, FlexibleContexts, TemplateHaskell, TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}+module Main (main) where+import Frames++-- This table has a column, @"drv"@, with values that Frames has in+-- the past inferred the wrong type for.++tableTypes "Mpg" "test/data/mpg.csv"++drvCol :: (Drv ∈ rs) => Record rs -> Text+drvCol = rget drv++cylCol :: (Cyl ∈ rs) => Record rs -> Int+cylCol = rget cyl++dispCol :: (Displ ∈ rs) => Record rs -> Double+dispCol = rget displ++main :: IO ()+main = return ()

@@ -1,20 +1,29 @@-{-# LANGUAGE CPP, TemplateHaskell, QuasiQuotes #-}+{-# LANGUAGE CPP, DataKinds, OverloadedStrings, QuasiQuotes,+             TemplateHaskell, TypeOperators #-} module Main (manualGeneration, main) where+import Control.Monad (unless)+import Data.Functor.Identity import Data.List (find) import Data.Monoid (First(..))+import qualified Data.Text as T import Language.Haskell.TH as TH import Language.Haskell.TH.Syntax (addDependentFile)-import Test.Hspec as H import Frames+import Frames.CSV (produceCSV) import DataCSV+import Pipes.Prelude (toListM) import PrettyTH+import System.IO (hClose)+import System.IO.Temp (withSystemTempFile)+import Test.Hspec as H+import Test.HUnit.Lang (assertFailure)  -- | 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 _) -> +                ListE <$> mapM (\x@(CsvExample _ c _) ->                                   [e|(x,$(generateCode "Row" c))|])                                csvExamples) @@ -26,11 +35,11 @@ overlappingGeneration :: String overlappingGeneration = m ++ "\n\n" ++ e   where m = $(do csvExamples <- TH.runIO (examplesFrom "test/examples.toml")-                 let Just (CsvExample _ managers _) = +                 let Just (CsvExample _ managers _) =                        find (\(CsvExample k _ _) -> k == "managers") csvExamples                  generateCode "ManagerRec" managers)         e = $(do csvExamples <- TH.runIO (examplesFrom "test/examples.toml")-                 let Just (CsvExample _ employees _) = +                 let Just (CsvExample _ employees _) =                        find (\(CsvExample k _ _) -> k == "employees") csvExamples                  generateCode "EmployeeRec" employees) @@ -39,23 +48,54 @@ -- string. Then load this file into a REPL that has @:set -- -XTemplateHaskell@ and evaluate @putStrLn $(manualGeneration -- "employees")@, for example.--- +-- -- 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 k = do csvExamples <- TH.runIO (examplesFrom "test/examples.toml")-                        maybe (error ("Table " ++ k ++ " not found")) -                              (generateCode "Row") +                        maybe (error ("Table " ++ k ++ " not found"))+                              (generateCode "Row")                               (getFirst $ foldMap aux csvExamples)   where aux :: CsvExample -> First String         aux (CsvExample k' c _) = if k == k' then pure c else mempty +type ManagersRow =+  Record ["id" :-> Int, "manager" :-> Text, "age" :-> Int, "pay" :-> Double]+ main :: IO () main = do   hspec $-    do describe "Haskell type generation" $ +    do describe "Haskell type generation" $          mapM_ (\(CsvExample k _ g, g') -> it k (g' `shouldBe` g)) csvTests        describe "Multiple tables" $-          do g <- H.runIO $ -                  generatedFrom "test/examples.toml" "managers_employees"+          do _g <- H.runIO $+                   generatedFrom "test/examples.toml" "managers_employees"              it "Shouldn't duplicate columns" pending+       describe "Writing CSV Data" $ do+         let csvInput = case find ((== "managers") . name . fst) csvTests of+                          Just (ex,_) -> csv ex+                          Nothing -> error "Couldn't find managers test data"+         frame <- H.runIO $+                  withSystemTempFile "FramesSpecOutput" $ \fp h -> do+                    hClose h+                    writeFile fp csvInput+                    inCoreAoS (readTable fp) :: IO (Frame ManagersRow)+         let Identity csvOutput = toListM (produceCSV frame)+         frame2 <- H.runIO $+                   withSystemTempFile "FramesSpecOutput" $ \fp h -> do+                     hClose h+                     writeFile fp (unlines csvOutput)+                     inCoreAoS (readTable fp) :: IO (Frame ManagersRow)++         -- 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+         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")