labels (empty) → 0.0.0
raw patch · 8 files changed
+534/−0 lines, 8 filesdep +basedep +bytestringdep +cassavasetup-changed
Dependencies added: base, bytestring, cassava, template-haskell, unordered-containers
Files
- CHANGELOG +2/−0
- LICENSE +30/−0
- README.md +141/−0
- Setup.hs +2/−0
- labels.cabal +34/−0
- src/Labels.hs +61/−0
- src/Labels/Cassava.hs +68/−0
- src/Labels/Internal.hs +196/−0
+ CHANGELOG view
@@ -0,0 +1,2 @@+0.0.0:+ * First version
+ LICENSE view
@@ -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.
+ README.md view
@@ -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+```++<table>+<tr><td>Construct a record</td><td><pre lang="haskell">+> (#foo := "hi", #bar := 123)+(#foo := "hi",#bar := 123)+</pre></td></tr>+<tr><td>Get fields of a record</td><td><pre lang="haskell">+> get #bar (#foo := "hi", #bar := 123)+123+> #bar (#foo := "hi", #bar := 123) -- or this convenience+123+</pre></td></tr>+<tr><td>Set fields of a record</td><td><pre lang="haskell">+> set #bar 66 (#foo := "hi", #bar := 123)+(#foo := "hi",#bar := 66)+</pre></td></tr>+<tr><td>Modify fields of a record</td><td><pre lang="haskell">+> modify #mu (*0.1) (#bar := "hi", #mu := 123)+(#bar := "hi",#mu := 12.3)+</pre></td></tr>+<tr><td>Add fields to a record</td><td><pre lang="haskell">+> cons (#mu := [1,2,3]) (#foo := "hi", #bar := 123)+(#mu := [1,2,3],#foo := "hi",#bar := 123)+</pre></td></tr>+<tr><td>Abstraction</td><td><pre lang="haskell">+> let double field record = set field (get field record * 2) record+> double #mu (#bar := "hi", #mu := 123)+(#bar := "hi",#mu := 246)+</pre></td></tr>+</table>++## 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))+<interactive>:133:31: error:+ • No instance for (Has+ "adj closer" a0 ("date" := String, "adj close" := Double))+ arising from a use of ‘get’+````
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ labels.cabal view
@@ -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
+ src/Labels.hs view
@@ -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
+ src/Labels/Cassava.hs view
@@ -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])
+ src/Labels/Internal.hs view
@@ -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]))+