vinyl 0.1.0.0 → 0.1.1.0
raw patch · 10 files changed
+191/−88 lines, 10 filesdep +mtl
Dependencies added: mtl
Files
- Data/Vinyl.hs +7/−5
- Data/Vinyl/Classes.hs +18/−0
- Data/Vinyl/Field.hs +7/−7
- Data/Vinyl/Lens.hs +15/−14
- Data/Vinyl/Rec.hs +76/−23
- Data/Vinyl/Relation.hs +23/−21
- Data/Vinyl/Unicode.hs +6/−6
- Data/Vinyl/Validation.hs +26/−0
- Data/Vinyl/Witnesses.hs +8/−8
- vinyl.cabal +5/−4
Data/Vinyl.hs view
@@ -4,11 +4,13 @@ , module Data.Vinyl.Field , module Data.Vinyl.Rec , module Data.Vinyl.Relation+ , module Data.Vinyl.Classes, ) where -import Data.Vinyl.Lens-import Data.Vinyl.Witnesses-import Data.Vinyl.Field-import Data.Vinyl.Rec-import Data.Vinyl.Relation+import Data.Vinyl.Classes+import Data.Vinyl.Field+import Data.Vinyl.Lens+import Data.Vinyl.Rec+import Data.Vinyl.Relation+import Data.Vinyl.Witnesses
+ Data/Vinyl/Classes.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}++module Data.Vinyl.Classes where++import Control.Applicative+import Control.Monad.Identity++class Apply (arr :: k -> k -> k) (f :: k -> *) where+ (<<*>>) :: f (arr a b) -> f a -> f b++class Run t where+ run :: Applicative f => t f -> f (t Identity)++newtype (f ~> g) x = NT { runNT :: f x -> g x }+
Data/Vinyl/Field.hs view
@@ -1,17 +1,17 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-} module Data.Vinyl.Field where -import GHC.TypeLits+import GHC.TypeLits -- A field is a symbol key and a type for its value. data (:::) :: Symbol -> * -> * where Field :: sy ::: t -instance (SingI sy, Show t) => Show (sy ::: t) where+instance SingI sy => Show (sy ::: t) where show Field = fromSing (sing :: Sing sy)
Data/Vinyl/Lens.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-} module Data.Vinyl.Lens ( module Control.Lens@@ -13,13 +14,14 @@ , rMod ) where -import Data.Vinyl.Rec-import Data.Vinyl.Field-import Data.Vinyl.Witnesses+import Data.Vinyl.Field+import Data.Vinyl.Rec+import Data.Vinyl.Witnesses -import Control.Lens+import Control.Lens+import Control.Monad.Identity -type RLens sy t = IElem (sy ::: t) fs => SimpleLens (Rec fs) t+type RLens sy t = IElem (sy ::: t) rs => SimpleLens (PlainRec rs) t rLens :: (sy ::: t) -> RLens sy t rLens f = rLens' f implicitly@@ -30,10 +32,9 @@ rMod = over . rLens -- Records have lenses-rLens' :: (f ~ (sy ::: t)) => f -> Elem f fs -> SimpleLens (Rec fs) t-rLens' _ Here = lens (\((_,x) :& xs) -> x) (\((k,_) :& xs) x -> (k,x) :& xs)+rLens' :: (r ~ (sy ::: t)) => r -> Elem r rs -> SimpleLens (PlainRec rs) t+rLens' _ Here = lens (\(x :& xs) -> runIdentity x) (\(_ :& xs) x -> Identity x :& xs) rLens' f (There p) = rLensPrepend $ rLens' f p -rLensPrepend :: SimpleLens (Rec fs) t -> SimpleLens (Rec (f ': fs)) t-rLensPrepend l = lens (\(_ :& xs) -> view l xs) (\(a :& xs) x -> a :& (set l x xs))-+rLensPrepend :: SimpleLens (PlainRec rs) t -> SimpleLens (PlainRec (l ': rs)) t+rLensPrepend l = lens (\(x :& xs) -> view l xs) (\(a :& xs) x -> a :& (set l x xs))
Data/Vinyl/Rec.hs view
@@ -1,50 +1,103 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Data.Vinyl.Rec ( Rec(..)+ , PlainRec , (=:) , (<+>)+ , fixRecord ) where -import Data.Vinyl.Field-import GHC.TypeLits+import Data.Vinyl.Classes+import Control.Applicative+import Control.Monad.Identity+import Data.Monoid+import Data.Vinyl.Field+import GHC.TypeLits --- A record is parameterized by a list of fields.-data Rec :: [*] -> * where- RNil :: Rec '[]- (:&) :: (f ~ (sy ::: t)) => (f, t) -> Rec fs -> Rec (f ': fs)+-- A record is parameterized by a list of fields and a functor+-- to be applied to each of those fields.+data Rec :: [*] -> (* -> *) -> * where+ RNil :: Rec '[] f+ (:&) :: (r ~ (sy ::: t)) => f t -> Rec rs f -> Rec (r ': rs) f infixr :& +-- Fixes a polymorphic record into the identity functor.+fixRecord :: (forall f. Applicative f => Rec rs f) -> PlainRec rs+fixRecord xs = xs++-- Fields of plain records are in the Identity functor.+type PlainRec rs = Rec rs Identity+ -- Appends records-(<+>) :: Rec as -> Rec bs -> Rec (as ++ bs)+(<+>) :: Rec as f -> Rec bs f -> Rec (as ++ bs) f RNil <+> xs = xs (x :& xs) <+> ys = x :& (xs <+> ys) infixl 8 <+> -- Shorthand for a record with a single field-(=:) :: sy ::: t -> t -> Rec '[sy ::: t]-a =: b = (a, b) :& RNil+(=:) :: Applicative f => sy ::: t -> t -> Rec '[sy ::: t] f+a =: b = pure b :& RNil -- Type level list append type family (as :: [*]) ++ (bs :: [*]) :: [*] type instance '[] ++ bs = bs type instance (a ': as) ++ bs = a ': (as ++ bs) --instance Show (Rec '[]) where+-- Type Class Instances+instance Show (Rec '[] f) where show RNil = "{}"-instance (SingI sy, Show t, Show (Rec fs)) => Show (Rec ((sy ::: t) ': fs)) where- show ((k,x) :& xs) = show k ++ " :=: " ++ show x ++ ", " ++ show xs +instance (SingI sy, Show (g t), Show (Rec fs g)) => Show (Rec ((sy ::: t) ': fs) g) where+ show (x :& xs) = show (Field :: sy ::: t) ++ " :=: " ++ show x ++ ", " ++ show xs where -instance Eq (Rec '[]) where+instance Eq (Rec '[] f) where _ == _ = True-instance (Eq t, Eq (Rec fs)) => Eq (Rec ((s ::: t) ': fs)) where- ((_,x) :& xs) == ((_,y) :& ys) = (x == y) && (xs == ys)+instance (Eq (g t), Eq (Rec fs g)) => Eq (Rec ((s ::: t) ': fs) g) where+ (x :& xs) == (y :& ys) = (x == y) && (xs == ys) +instance Apply (~>) (Rec rs) where+ RNil <<*>> RNil = RNil+ (f :& fs) <<*>> (x :& xs) = runNT f x :& (fs <<*>> xs)++instance Run (Rec rs) where+ run RNil = pure RNil+ run (x :& xs) = (:&) <$> (pure <$> x) <*> run xs++instance Show a => Show (Identity a) where+ show (Identity x) = show x+++{-+ex :: Rec Name Identity+ex = Identity "jon"+ :& Identity "sterling"+ :& Identity 20+ :& RNil++verifyFirst = NT $ \str -> Failure ["asdfadS"]+verifyLast = NT $ \str -> Failure ["uhoh"]+verifyAge = NT $ \_ -> Failure ["uhoh"]++ex2 :: Rec Name (Identity ~> Result [String])+ex2 = verifyFirst+ :& verifyLast+ :& verifyAge+ :& RNil++ex3 = ex2 <<*>> ex+ex4 = run ex3+-}
Data/Vinyl/Relation.hs view
@@ -1,13 +1,14 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} module Data.Vinyl.Relation ( (<:)(..)@@ -16,12 +17,13 @@ , rIso ) where -import Data.Vinyl.Witnesses-import Data.Vinyl.Field-import Data.Vinyl.Rec-import Data.Vinyl.Lens+import Data.Vinyl.Field+import Data.Vinyl.Lens+import Data.Vinyl.Rec+import Data.Vinyl.Witnesses+import Control.Monad.Identity -import GHC.Prim (Constraint)+import GHC.Prim (Constraint) -- A subtyping relation class (IsSubtype r1 r2) => r1 <: r2 where@@ -30,7 +32,7 @@ -- On record is a subtype of another if the fields of the latter are a -- subset of the fields of the former. type family IsSubtype r1 r2 :: Constraint-type instance IsSubtype (Rec ss) (Rec ts) = ISubset ts ss+type instance IsSubtype (Rec ss f) (Rec ts f) = ISubset ts ss -- If two records types are subtypes of each other, that means that they -- differ only in order of fields.@@ -40,15 +42,15 @@ (~=) :: (Eq a, a :~: b) => a -> b -> Bool x ~= y = x == (cast y) -instance Rec xs <: (Rec '[]) where+instance Rec xs f <: Rec '[] f where cast _ = RNil -instance (y ~ (sy ::: t), IElem y xs, Rec xs <: Rec ys) => Rec xs <: Rec (y ': ys) where- cast r = (field, rGet field r) :& cast r- where field = lookupField implicitly r+instance (y ~ (sy ::: t), IElem y xs, PlainRec xs <: PlainRec ys) => PlainRec xs <: PlainRec (y ': ys) where+ cast r = Identity (rGet field r) :& cast r+ where field = lookupField (implicitly :: Elem y xs) r -lookupField :: Elem x xs -> Rec xs -> x-lookupField Here ((k,_) :& _) = k+lookupField :: Elem x xs -> Rec xs f -> x+lookupField Here (_ :& _) = Field lookupField (There p) (_ :& xs) = lookupField p xs rIso :: (r1 :~: r2) => SimpleIso r1 r2
Data/Vinyl/Unicode.hs view
@@ -1,13 +1,13 @@-{-# LANGUAGE UnicodeSyntax #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnicodeSyntax #-} module Data.Vinyl.Unicode where -import Data.Vinyl.Rec-import Data.Vinyl.Relation-import Data.Vinyl.Witnesses+import Data.Vinyl.Rec+import Data.Vinyl.Relation+import Data.Vinyl.Witnesses type x ∈ xs = IElem x xs type xs ⊆ ys = ISubset xs ys
+ Data/Vinyl/Validation.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE TypeOperators #-}++module Data.Vinyl.Validation where++import Data.Vinyl.Classes+import Control.Applicative+import Control.Monad.Identity+import Data.Monoid++data Result e a+ = Failure e+ | Success a+ deriving (Show, Eq)++type Validator e = Identity ~> Result e++instance Functor (Result e) where+ fmap f (Success x) = Success (f x)+ fmap f (Failure e) = Failure e++instance Monoid e => Applicative (Result e) where+ pure = Success+ (Success f) <*> (Success x) = Success (f x)+ (Failure e) <*> (Success x) = Failure e+ (Success f) <*> (Failure e) = Failure e+ (Failure e) <*> (Failure e') = Failure (e <> e')
Data/Vinyl/Witnesses.hs view
@@ -1,12 +1,12 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-} module Data.Vinyl.Witnesses where
vinyl.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: vinyl-version: 0.1.0.0+version: 0.1.1.0 synopsis: Extensible Records -- description: license: MIT@@ -10,7 +10,8 @@ author: Jonathan Sterling maintainer: jonsterling@me.com -- copyright:-category: Data+category: Records+stability: Experimental build-type: Simple cabal-version: >=1.8 @@ -23,6 +24,6 @@ library- exposed-modules: Data.Vinyl, Data.Vinyl.Field, Data.Vinyl.Lens, Data.Vinyl.Witnesses, Data.Vinyl.Rec, Data.Vinyl.Relation, Data.Vinyl.Unicode+ exposed-modules: Data.Vinyl, Data.Vinyl.Field, Data.Vinyl.Lens, Data.Vinyl.Witnesses, Data.Vinyl.Rec, Data.Vinyl.Relation, Data.Vinyl.Unicode, Data.Vinyl.Classes, Data.Vinyl.Validation -- other-modules:- build-depends: base ==4.6.*, lens >=3.0, ghc-prim+ build-depends: base ==4.6.*, lens >=3.0, ghc-prim, mtl