diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,6 @@ +0.1.1: + * Add "project" function. + 0.1.0: * Drop the convenience accessor #foo. Must use get #foo diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -52,88 +52,3 @@ (#bar := "hi",#mu := 246) - -## Reading CSV files with Cassava - -Import the instances for `FromNamedRecord`: - -``` haskell -import Labels.Cassava -``` - -Then just specify the type you want to load: - -``` haskell -> let Right (_,rows :: Vector ("salary" := Int, "name" := Text)) = decodeByName "name,salary\r\nJohn,27\r\n" -> rows -[(#salary := 27,#name := "John")] -``` - -Non-existent fields or invalid types result in a parse error: - -``` haskell -> decodeByName "name,salary\r\nJohn,27\r\n" :: Either String (Header, Vector ("name" := Text, "age" := Int)) -Left "parse error (Failed reading: conversion error: Missing field age) at \"\\r\\n\"" -> decodeByName "name,salary\r\nJohn,27\r\n" :: Either String (Header, Vector ("name" := Text, "salary" := Char)) -Left "parse error (Failed reading: conversion error: expected Char, got \"27\") at \"\\r\\n\"" -``` - -Example with Yahoo!'s market data for AAPL: - -``` haskell -> Right (headers,rows :: Vector ("date" := String, "high" := Double, "low" := Double)) <- fmap decodeByName (LB.readFile "AAPL.csv") -> headers -["date","open","high","low","close","volume","adj close"] -``` - -We can print the rows as-is: - -``` haskell -> mapM_ print (V.take 2 rows) -(#date := "2016-08-10",#high := 108.900002,#low := 107.760002) -(#date := "2016-08-09",#high := 108.940002,#low := 108.010002) -``` - -Accessing fields is natural as anything: - -``` haskell -> V.sum (V.map (get #low) rows) -2331.789993 -``` - -We can just make up new fields on the fly: - -``` haskell -> let diffed = V.map (\row -> cons (#diff := (get #high row - get #low row)) row) rows -> mapM_ print (V.take 2 diffed) -(#diff := 1.1400000000000006,#date := "2016-08-10",#high := 108.900002,#low := 107.760002) -(#diff := 0.9300000000000068,#date := "2016-08-09",#high := 108.940002,#low := 108.010002) -``` - -Sometimes a CSV file will have non-valid Haskell identifiers or -spaces, e.g. `adj close` here: - -``` haskell -> Right (headers,rows :: Vector ("date" := String, "adj close" := Double)) <- fmap decodeByName (LB.readFile "AAPL.csv") -> mapM_ print (V.take 2 rows) -(#date := "2016-08-10",#adj close := 108.0) -(#date := "2016-08-09",#adj close := 108.809998) -``` - -Just use the `$("adj close")` syntax: - -``` haskell -> mapM_ print (V.take 2 (V.map (get $("adj close")) rows)) -108.0 -108.809998 -``` - -It still checks the name and type: - -``` haskell -> mapM_ print (V.take 2 (V.map (get $("adj closer")) rows)) -:133:31: error: - • No instance for (Has - "adj closer" a0 ("date" := String, "adj close" := Double)) - arising from a use of ‘get’ -```` diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/labels.cabal b/labels.cabal --- a/labels.cabal +++ b/labels.cabal @@ -1,8 +1,7 @@ name: labels -version: 0.1.0 -synopsis: Declare and access tuple fields with labels -description: Declare and access tuple fields with labels. - An approach to anonymous records. +version: 0.1.1 +synopsis: Anonymous records via named tuples +description: Declare and access tuple fields with labels. An approach to anonymous records. homepage: https://github.com/chrisdone/labels#readme license: BSD3 license-file: LICENSE @@ -19,14 +18,9 @@ hs-source-dirs: src ghc-options: -Wall -O2 exposed-modules: Labels, - Labels.Internal, - Labels.Cassava + Labels.Internal build-depends: base >= 4.7 && < 5, - template-haskell, - -- Integrations - cassava, - bytestring, - unordered-containers + template-haskell default-language: Haskell2010 source-repository head diff --git a/src/Labels.hs b/src/Labels.hs --- a/src/Labels.hs +++ b/src/Labels.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Rank2Types #-} -- | Labels for fields in a tuple. -- -- Enable these extensions: @@ -44,18 +49,53 @@ -- >>> let double field record = set field (get field record * 2) record -- >>> double #mu (#bar := "hi", #mu := 123) -- (#bar := "hi",#mu := 246) +-- +-- Lenses: +-- +-- >>> over (lens #sub . lens #foo) (*2) (#bar := "hello", #sub := (#foo := 123)) +-- (#bar := "hello",#sub := #foo := 246) +-- +-- Projection: +-- +-- >>> project (#bar := "hello", #foo := 3, #mu := "hi") :: ("bar" := String, "foo" := Int) +-- (#bar := "hello",#foo := 3) +-- +-- Field order projection: +-- +-- >>> project (#bar := "hello", #foo := 3) :: ("foo" := Int, "bar" := String) +-- (#foo := 3,#bar := "hello") module Labels - (-- Field access - get - ,set - ,modify - ,cons +-- Field access + ( get + , set + , modify + , lens + , cons + , project -- Construction - ,(:=)(..) - ,Has - ,Cons - ) + , (:=)(..) + , Has + , Cons + , Project) where +import Data.Proxy +import GHC.TypeLits import Labels.Internal + +type Lens s t a b = forall f. Functor f => (a -> f b) -> (s -> f t) + +-- | Make a lens out of the label. Example: @over (lens #salary) (* 1.1) employee@ +lens + :: Has label value record + => Proxy (label :: Symbol) -> Lens record record value value +lens label f record = + fmap (\value -> set label value record) (f (get label record)) +{-# INLINE lens #-} + +-- | Strictly modify a field by doing: @modify #salary (* 1.1) employee@ +modify :: Has label value record => Proxy label -> (value -> value) -> record -> record +modify f g r = set f (g v) r + where !v = get f r +{-# INLINE modify #-} diff --git a/src/Labels/Cassava.hs b/src/Labels/Cassava.hs deleted file mode 100644 --- a/src/Labels/Cassava.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Provide instances of FromNamedRecord for named tuples up to 24 fields. --- --- Import like: @import Labels.Cassava ()@ --- - -module Labels.Cassava where - -import qualified Data.ByteString.Char8 as S8 -import Data.Csv -import qualified Data.HashMap.Strict as M -import Data.Proxy -import GHC.TypeLits -import Labels -import Language.Haskell.TH - -$(let makeInstance :: Int -> Q Dec - makeInstance size = - instanceD - context - (appT (conT ''FromNamedRecord) instHead) - [ funD - 'parseNamedRecord - [clause [varP hash_var] (normalB (tuplize (map getter [1::Int .. size]))) []]] - where - l_tyvar j = mkName ("l" ++ show j) - v_tyvar j = mkName ("v" ++ show j) - hash_var = mkName "hash" - context = - return - (concat - (map - (\i -> - [AppT (ConT ''KnownSymbol) (VarT (l_tyvar i)) - ,AppT (ConT ''FromField) (VarT (v_tyvar i))]) - [1 .. size])) - instHead = - foldl - appT - (tupleT size) - (map - (\j -> - appT - (appT (conT ''(:=)) (varT (l_tyvar j))) - (varT (v_tyvar j))) - [1 .. size]) - tuplize [] = fail "Need at least one field." - tuplize [j] = j - tuplize js = foldl (\acc (i,g) -> infixApp acc (varE (if i == 1 - then '(<$>) - else '(<*>))) g) - tupSectionE - (zip [1::Int ..] js) - tupSectionE = - lamE (map (varP.var) [1..size]) - (tupE (map (varE.var) [1..size])) - where var i = mkName ("t" ++ show i) - getter (j::Int) = - [|let proxy = Proxy :: Proxy $(varT (l_tyvar j)) - in case M.lookup (S8.pack (symbolVal proxy)) hash of - Nothing -> fail ("Missing field " ++ symbolVal proxy) - Just v -> fmap (proxy :=) (parseField v)|] - in mapM makeInstance [1..24]) diff --git a/src/Labels/Internal.hs b/src/Labels/Internal.hs --- a/src/Labels/Internal.hs +++ b/src/Labels/Internal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -30,6 +31,8 @@ #if __GLASGOW_HASKELL__ >= 800 import GHC.OverloadedLabels +#else +import Data.Proxy #endif -------------------------------------------------------------------------------- @@ -50,26 +53,38 @@ compare (_ := x) (_ := y) = x `compare` y {-# INLINE compare #-} -instance (Show t) => Show (l := t) where - show (l := t) = "#" ++ (symbolVal l) ++ " := " ++ show t +instance (Show t) => + Show (l := t) where + showsPrec p (l := t) = + showParen (p > 10) (showString ("#" ++ (symbolVal l) ++ " := " ++ show t)) -------------------------------------------------------------------------------- +-- Labels + +#if __GLASGOW_HASKELL__ >= 800 +instance l ~ l' => + IsLabel (l :: Symbol) (Proxy l') where + fromLabel _ = Proxy + {-# INLINE fromLabel #-} +#endif + +instance IsString (Q Exp) where + fromString str = [|Proxy :: Proxy $(litT (return (StrTyLit str)))|] + +-------------------------------------------------------------------------------- -- Basic accessors +-- | A record has a certain field which can be set and get. class Has (label :: Symbol) value record | label record -> value where -- | Get a field by doing: @get #salary employee@ get :: Proxy label -> record -> value -- | Set a field by doing: @set #salary 54.00 employee@ set :: Proxy label -> value -> record -> record --- | Modify a field by doing: @modify #salary (* 1.1) employee@ -modify :: Has label value record => Proxy label -> (value -> value) -> record -> record -modify f g r = set f (g (get f r)) r -{-# INLINE modify #-} - -------------------------------------------------------------------------------- --- Cons two records together +-- Cons a field onto a record +-- | A field can be consed onto the beginning of a record. class Cons label value record where type Consed label value record -- | Cons a field onto a record by doing: @cons (#foo := 123) record@ @@ -86,21 +101,17 @@ {-# INLINE cons #-} -------------------------------------------------------------------------------- --- Labels - -#if __GLASGOW_HASKELL__ >= 800 -instance l ~ l' => - IsLabel (l :: Symbol) (Proxy l') where - fromLabel _ = Proxy - {-# INLINE fromLabel #-} -#endif +-- Projection -instance IsString (Q Exp) where - fromString str = [|Proxy :: Proxy $(litT (return (StrTyLit str)))|] +-- | A record can be narrowed or have its order changed by projecting +-- into record type. +class Project from to where + project :: from -> to -------------------------------------------------------------------------------- -- TH-derived instances +-- Generate Cons instances. $(let makeInstance size = [d|instance Cons $(varT label_tyvar) $(varT value_tyvar) $tupTy where type Consed $(varT label_tyvar) $(varT value_tyvar) $tupTy = $newTupTy @@ -130,6 +141,7 @@ [1 .. size]) in fmap concat (mapM makeInstance [2 .. 24])) +-- Generate Has instances. $(let makeInstance size slot = [d|instance Has $(varT l_tyvar) $(varT a_tyvar) $instHead where get _ = $getImpl @@ -188,3 +200,40 @@ (mapM (\size -> mapM (\slot -> makeInstance size slot) [1 .. size]) [1 .. 24])) + +-- Generate Project instances. +$(let labelt i = varT (mkName ("l" ++ show i)) + labelv i = varE (mkName ("l" ++ show i)) + labelp i = varP (mkName ("l" ++ show i)) + typ i = varT (mkName ("t" ++ show i)) + r = varT (mkName "r") + rp = varP (mkName "r") + rv = varE (mkName "r") + in sequence + [ instanceD + (sequence + ([[t|KnownSymbol $(labelt i)|] | i <- [1 :: Int .. n]] ++ + [ [t|Has ($(labelt i) :: Symbol) $(typ i) $(r)|] + | i <- [1 :: Int .. n] + ])) + [t|Project $(r) $(foldl + appT + (tupleT n) + [[t|$(labelt i) := $(typ i)|] | i <- [1 .. n]])|] + [ funD + 'project + [ clause + [rp] + (normalB + (tupE + [ [|$(labelv i) := get $(labelv i) $(rv)|] + | i <- [1 .. n] + ])) + [ valD (labelp i) (normalB [|Proxy :: Proxy $(labelt i)|]) [] + | i <- [1 .. n] + ] + ] + , return (PragmaD (InlineP 'project Inline FunLike AllPhases)) + ] + | n <- [1 .. 24] + ])