diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,2 @@ +0.0.0: + * First version diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Chris Done (c) 2016 + +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 Chris Done 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,141 @@ +# labels + +Declare and access tuple fields with labels + +This package is experimental, exploring the design space opened up by +the implemented and to-be-implemented work on extensible records in GHC. + +*Note: You need GHC 8.0.1 for the `#foo` syntax, otherwise you have to + use `$("foo")` which works on GHC 7.10.* + +## Basic examples + +The [haddock docs are here.](https://chrisdone.github.io/labels/) + +Enable these extensions: + +* In GHCi: `:set -XOverloadedLabels -XTypeOperators -XDataKinds -XFlexibleContexts` + +* In a module: `{-# LANGUAGE OverloadedLabels, TypeOperators, DataKinds, FlexibleContexts #-}` + +Let's use GHCi: + +``` haskell +> import Labels +> :set -XOverloadedLabels -XTypeOperators -XDataKinds -XFlexibleContexts +``` + + + + + + + + +
Construct a record
+> (#foo := "hi", #bar := 123)
+(#foo := "hi",#bar := 123)
+
Get fields of a record
+> get #bar (#foo := "hi", #bar := 123)
+123
+> #bar (#foo := "hi", #bar := 123) -- or this convenience
+123
+
Set fields of a record
+> set #bar 66 (#foo := "hi", #bar := 123)
+(#foo := "hi",#bar := 66)
+
Modify fields of a record
+> modify #mu (*0.1) (#bar := "hi", #mu := 123)
+(#bar := "hi",#mu := 12.3)
+
Add fields to a record
+> cons (#mu := [1,2,3]) (#foo := "hi", #bar := 123)
+(#mu := [1,2,3],#foo := "hi",#bar := 123)
+
Abstraction
+> let double field record = set field (get field record * 2) record
+> double #mu (#bar := "hi", #mu := 123)
+(#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 #low rows) +2331.789993 +``` + +We can just make up new fields on the fly: + +``` haskell +> let diffed = V.map (\row -> cons (#diff := (#high row - #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 new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/labels.cabal b/labels.cabal new file mode 100644 --- /dev/null +++ b/labels.cabal @@ -0,0 +1,34 @@ +name: labels +version: 0.0.0 +synopsis: Declare and access tuple fields with labels +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 +author: Chris Done +maintainer: chrisdone@gmail.com +copyright: 2016 Chris Done +category: Development +build-type: Simple +extra-source-files: README.md, CHANGELOG +stability: Experimental +cabal-version: >=1.10 + +library + hs-source-dirs: src + ghc-options: -Wall -O2 + exposed-modules: Labels, + Labels.Internal, + Labels.Cassava + build-depends: base >= 4.7 && < 5, + template-haskell, + -- Integrations + cassava, + bytestring, + unordered-containers + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/chrisdone/labels diff --git a/src/Labels.hs b/src/Labels.hs new file mode 100644 --- /dev/null +++ b/src/Labels.hs @@ -0,0 +1,61 @@ +-- | Labels for fields in a tuple. +-- +-- Enable these extensions: +-- +-- In GHCi: +-- +-- @ +-- :set -XOverloadedLabels -XTypeOperators -XDataKinds -XFlexibleContexts +-- @ +-- +-- In a module: +-- +-- @ +-- {-\# LANGUAGE OverloadedLabels, TypeOperators, DataKinds, FlexibleContexts \#-} +-- @ +-- +-- Construct a record: +-- +-- >>> (#foo := "hi", #bar := 123) +-- (#foo := "hi",#bar := 123) +-- +-- Get fields of a record: +-- +-- >>> get #bar (#foo := "hi", #bar := 123) +-- 123 +-- +-- Set fields of a record: +-- +-- >>> set #bar 66 (#foo := "hi", #bar := 123) +-- (#foo := "hi",#bar := 66) +-- +-- Modify fields of a record: +-- +-- >>> modify #mu (*0.1) (#bar := "hi", #mu := 123) +-- (#bar := "hi",#mu := 12.3) +-- +-- Add fields to a record: +-- +-- >>> cons (#mu := [1,2,3]) (#foo := "hi", #bar := 123) +-- (#mu := [1,2,3],#foo := "hi",#bar := 123) +-- +-- Abstraction: +-- +-- >>> let double field record = set field (get field record * 2) record +-- >>> double #mu (#bar := "hi", #mu := 123) +-- (#bar := "hi",#mu := 246) + +module Labels + (-- Field access + get + ,set + ,modify + ,cons + -- Construction + ,(:=)(..) + ,Has + ,Cons + ) + where + +import Labels.Internal diff --git a/src/Labels/Cassava.hs b/src/Labels/Cassava.hs new file mode 100644 --- /dev/null +++ b/src/Labels/Cassava.hs @@ -0,0 +1,68 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Labels/Internal.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE OverloadedLabels #-} +#endif +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | This module provides a way to name the fields in a regular +-- Haskell tuple and then look them up later, statically. + +module Labels.Internal where + +import Data.Data +import Data.String +import GHC.TypeLits +import Language.Haskell.TH + +#if __GLASGOW_HASKELL__ >= 800 +import GHC.OverloadedLabels +#endif + +-------------------------------------------------------------------------------- +-- A labelled value + +-- | Field named @l@ labels value of type @t@. +-- Example: @(#name := \"Chris\") :: (\"name\" := String)@ +data label := value = KnownSymbol label => Proxy label := value +deriving instance Typeable (:=) +deriving instance Typeable (label := value) +infix 6 := + +instance (Eq value) => Eq (label := value) where + _ := x == _ := y = x == y + {-# INLINE (==) #-} + +instance (Ord value) => Ord (label := value) where + compare (_ := x) (_ := y) = x `compare` y + {-# INLINE compare #-} + +instance (Show t) => Show (l := t) where + show (l := t) = "#" ++ (symbolVal l) ++ " := " ++ show t + +-------------------------------------------------------------------------------- +-- Basic accessors + +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 + +class Cons label value record where + type Consed label value record + -- | Cons a field onto a record by doing: @cons (#foo := 123) record@ + cons :: (label := value) -> record -> Consed label value record + +instance Cons label value () where + type Consed label value () = (label := value) + cons field () = field + {-# INLINE cons #-} + +instance Cons label value (label' := value') where + type Consed label value (label' := value') = (label := value,label' := value') + cons field field2 = (field,field2) + {-# INLINE cons #-} + +-------------------------------------------------------------------------------- +-- Labels + +#if __GLASGOW_HASKELL__ >= 800 +instance l ~ l' => + IsLabel (l :: Symbol) (Proxy l') where + fromLabel _ = Proxy + {-# INLINE fromLabel #-} + +instance Has l a r => + IsLabel (l :: Symbol) (r -> a) where + fromLabel _ = get (Proxy :: Proxy l) + {-# INLINE fromLabel #-} +#endif + +instance IsString (Q Exp) where + fromString str = [|Proxy :: Proxy $(litT (return (StrTyLit str)))|] + +-------------------------------------------------------------------------------- +-- TH-derived 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 + cons $(varP field_name) $tupPat = $tupEx + {-# INLINE cons #-}|] + where label_tyvar = mkName "label" + value_tyvar = mkName "value" + field_name = mkName "field" + tupPat = tupP (map (\j -> varP (mkName ("v" ++ show j))) [1..size]) + tupEx = tupE (varE field_name : map (\j -> varE (mkName ("v" ++ show j))) [1..size]) + newTupTy = + foldl + appT + (tupleT (size+1)) + ((appT (appT (conT ''(:=)) (varT label_tyvar)) (varT value_tyvar)) : + (map + (\j -> + varT (mkName ("u" ++ show j))) + [1 .. size])) + tupTy = + foldl + appT + (tupleT size) + (map + (\j -> + varT (mkName ("u" ++ show j))) + [1 .. size]) + in fmap concat (mapM makeInstance [2 .. 24])) + +$(let makeInstance size slot = + [d|instance Has $(varT l_tyvar) $(varT a_tyvar) $instHead + where get _ = $getImpl + {-# INLINE get #-} + set _ = $setImpl + {-# INLINE set #-} + |] + where + l_tyvar = mkName "l" + a_tyvar = mkName "a" + getImpl = + lamE + [ tupP (map (\j -> if j == slot then infixP wildP '(:=) (varP a_var) else wildP) + [1 .. size])] + (varE a_var) + where a_var = mkName "a" + setImpl = + lamE + [ varP v_var + ,tupP + (map + (\j -> + if j == slot + then infixP + (varP (nth_proxy_var j)) + '(:=) + wildP + else varP (nth_var j)) + [1 .. size])] + (tupE + (map + (\j -> + if j == slot + then appE + (appE (conE '(:=)) (varE (nth_proxy_var j))) + (if j == slot + then varE v_var + else varE (nth_var j)) + else varE (nth_var j)) + [1 .. size])) + where nth_var i = mkName ("u_" ++ show i) + nth_proxy_var i = mkName ("p_" ++ show i) + v_var = mkName "v" + instHead = + foldl + appT + (tupleT size) + (map + (\j -> + if j == slot + then appT (appT (conT ''(:=)) (varT l_tyvar)) (varT a_tyvar) + else varT (mkName ("u" ++ show j))) + [1 .. size]) + in fmap + (concat . concat) + (mapM (\size -> mapM (\slot -> makeInstance size slot) + [1 .. size]) + [1 .. 24])) +