Permalink
Browse files

appending/merging records without duplicate keys

  • Loading branch information...
mikeplus64 committed Dec 13, 2012
1 parent 9cc8a91 commit 26ac1ec963f9f4351bfd53f91387b71cd64349dc
Showing with 29 additions and 39 deletions.
  1. +1 −1 record.cabal
  2. +28 −0 src/Data/Record.hs
  3. +0 −38 src/Example.hs
View
@@ -1,5 +1,5 @@
name: record
-version: 0.1.0.23
+version: 0.1.0.24
synopsis: Efficient, type safe records implemented using GADTs and type level strings.
homepage: http://quasimal.com/projects/records
license: BSD3
View
@@ -160,3 +160,31 @@ instance Update P xs k a => Update P (k0 := a0 ': xs) k a where
write n y (Cp x xs) = x & write n y xs
alter n f (Cp x xs) = x & alter n f xs
+class NotElem (x :: a) (xs :: [a])
+instance NotElem y '[ x ]
+instance NotElem y xs => NotElem y (x ': xs)
+
+class AllNotElem (xs :: [a]) (ys :: [a])
+instance AllNotElem '[] ys
+instance AllNotElem xs '[]
+instance (NotElem y xs, AllNotElem ys xs) => AllNotElem (y ': ys) (x ': xs)
+
+type family Keys (xs :: [F k a]) :: [k]
+type instance Keys '[] = '[]
+type instance Keys (k := a ': xs) = k ': Keys xs
+
+-- | Append two type-level lists
+type family (++) (x :: [a]) (y :: [a]) :: [a]
+type instance '[] ++ ys = ys
+type instance (x ': xs) ++ ys = x ': (xs ++ ys)
+
+class Append w r0 r1 where
+ -- | Append two records, making sure first that there are no duplicate fields
+ append :: AllNotElem (Keys r0) (Keys r1) => Record w r0 -> Record w r1 -> Record w (r0 ++ r1)
+instance Append w '[] ys where
+ append _ ys = ys
+instance (AllNotElem (Keys xs) (Keys ys), Append P xs ys) => Append P (x ': xs) ys where
+ append (Cp x xs) ys = Cp x (append xs ys)
+instance (AllNotElem (Keys xs) (Keys ys), Append (w :: * -> *) xs ys) => Append w (x ': xs) ys where
+ append (Ct x xs) ys = Ct x (append xs ys)
+
View
@@ -1,40 +1,2 @@
{-# LANGUAGE TypeOperators, DataKinds, QuasiQuotes #-}
-import Data.Record
-import Control.Arrow
-
-type Point
- = '[ "x" ::= Double
- , "y" ::= Double
- , "z" ::= Double ]
-
-type Sphere
- = Point ++ '[ "radius" ::= Double ]
-
-origin :: Record Point
-origin = 0 ::: 0 ::: 0 ::: End
-
-bigSphere :: Record Sphere
-bigSphere = origin & 1737100 ::: End
-
-otherSphere :: Record Sphere
-otherSphere = ([key|y|] =: 340 >>> [key|x|] =: 1003) origin & 540 ::: End
-
-main :: IO ()
-main = do
- print origin
- print bigSphere
- print otherSphere
-
- putStrLn $ "x of the origin = " ++ show (origin ! [key|x|])
- putStrLn $ "radius of bigSphere = " ++ show (bigSphere ! [key|radius|])
- putStrLn $ "x of otherSphere = " ++ show (otherSphere ! [key|x|])
-
- putStrLn "What colour is otherSphere?"
- colour <- getLine
- putStrLn "Does it enjoy walks in the park?"
- walks <- readLn
-
- let new = colour ::: walks ::: otherSphere :: Record ("colour" ::= String & "walks" ::= Bool & Sphere)
- putStrLn $ "To be honest, " ++ new ! [key|colour|] ++ " is a pretty crappy colour."
- putStrLn $ "Although I agree; I " ++ (if new ! [key|walks|] then "like" else "dislike") ++ " walks too."

0 comments on commit 26ac1ec

Please sign in to comment.