Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
  • 3 commits
  • 3 files changed
  • 0 comments
  • 1 contributor

Showing 3 changed files with 46 additions and 11 deletions. Show diff stats Hide diff stats

  1. +1 1  record.cabal
  2. +31 6 src/Data/Record.hs
  3. +14 4 src/Example.hs
2  record.cabal
... ... @@ -1,5 +1,5 @@
1 1 name: record
2   -version: 1.0.3
  2 +version: 1.0.4
3 3 synopsis: Efficient, type safe records implemented using GADTs and type level strings.
4 4 homepage: http://quasimal.com/projects/records
5 5 license: BSD3
37 src/Data/Record.hs
@@ -43,7 +43,6 @@ import Language.Haskell.TH.Syntax
43 43 import Language.Haskell.TH.Quote
44 44 import Language.Haskell.TH.Lib
45 45 import Control.Monad
46   -import qualified Control.Category as C
47 46 import Data.Monoid
48 47
49 48 -- | A key of a record. This does not exist at runtime, and as a tradeoff,
@@ -62,19 +61,45 @@ data RecordT w r where
62 61 E :: RecordT w '[]
63 62 type Record = RecordT Pure
64 63
  64 +{-# INLINE (&) #-}
  65 +{-# INLINE end #-}
65 66 (&) :: Wrap w e -> RecordT w r -> RecordT w (k := e ': r)
66 67 (&) = C
67 68 infixr 4 &
68 69 end :: RecordT w '[]
69 70 end = E
70 71
  72 +instance Eq (RecordT w '[]) where
  73 + {-# INLINE (==) #-}
  74 + _ == _ = True
  75 +
  76 +instance ( Eq (Wrap w x)
  77 + , Eq (RecordT w xs))
  78 + => Eq (RecordT w (k := x ': xs)) where
  79 + {-# INLINE (==) #-}
  80 + C x xs == C y ys = x == y && xs == ys
  81 +
  82 +instance Ord (RecordT w '[]) where
  83 + {-# INLINE compare #-}
  84 + compare _ _ = EQ
  85 +
  86 +instance ( Ord (Wrap w x)
  87 + , Ord (RecordT w xs))
  88 + => Ord (RecordT w (k := x ': xs)) where
  89 + {-# INLINE compare #-}
  90 + compare (C x xs) (C y ys) = compare (compare x y) (compare xs ys)
  91 +
71 92 instance Show (RecordT w '[]) where
72 93 show _ = "end"
73 94
74   -instance (Show a, Show (Record xs)) => Show (Record (k := a ': xs)) where
  95 +instance ( Show a
  96 + , Show (Record xs))
  97 + => Show (Record (k := a ': xs)) where
75 98 show (C x xs) = show x ++ " & " ++ show xs
76 99
77   -instance (Show (w a), Show (RecordT w xs)) => Show (RecordT w (k := a ': xs)) where
  100 +instance ( Show (w a)
  101 + , Show (RecordT w xs))
  102 + => Show (RecordT w (k := a ': xs)) where
78 103 show (C x xs) = show x ++ " & " ++ show xs
79 104
80 105 instance Monoid (RecordT w '[]) where
@@ -83,9 +108,9 @@ instance Monoid (RecordT w '[]) where
83 108 mappend _ _ = end
84 109 mempty = end
85 110
86   -instance (Monoid (Wrap w x)
87   - , Monoid (RecordT w xs))
88   - => Monoid (RecordT w (k := x ': xs)) where
  111 +instance ( Monoid (Wrap w x)
  112 + , Monoid (RecordT w xs))
  113 + => Monoid (RecordT w (k := x ': xs)) where
89 114 {-# INLINE mappend #-}
90 115 mappend (C x xs) (C y ys) = mappend x y & mappend xs ys
91 116 mempty = undefined -- impossible to reach anyway
18 src/Example.hs
... ... @@ -1,7 +1,8 @@
1 1 {-# LANGUAGE TypeOperators, DataKinds, QuasiQuotes #-}
2 2 import Data.Record
3 3 import Data.IORef
4   -import GHC.TypeLits
  4 +import Data.Monoid
  5 +import GHC.TypeLits -- I get a GHC panic without this module
5 6
6 7 type Point
7 8 = '[ "x" := Double
@@ -41,18 +42,27 @@ main = do
41 42 print frozenPoint
42 43 -- 0.0 & 1.0 & 2.0 & (255,255,0) & end
43 44
44   - let greg :: Record User
  45 + let greg, tony :: Record User
45 46 greg = "GREG" & "Sir Greg of Gerg" & "Male" & "Gregland" & end
  47 + tony = "Scarface" & "Tony Montana" & "Male" & "Cuba" & end
46 48
47 49 makeSpy :: Record User -> RecordT Maybe User
48 50 makeSpy = [set|real name|] Nothing . box Just
49 51
50 52 print greg
51 53 -- "GREG" & "Sir Greg of Gerg" & "Male" & "Gregland" & end
52   -
  54 + print tony
  55 + -- "Scarface" & "Tony Montana" & "Male" & "Cuba" & end
53 56 print (makeSpy greg)
54 57 -- Just "GREG" & Nothing & Just "Male" & Just "Gregland" & end
55   -
  58 + print (makeSpy tony)
  59 + -- Just "Scarface" & Nothing & Just "Male" & Just "Cuba" & end
56 60 print (run (makeSpy greg))
  61 + -- Nothing
  62 + print (run (makeSpy tony))
  63 + -- Nothing
  64 + print (greg <> tony)
  65 + -- "GREGScarface" & "Sir Greg of GergTony Montana" & "MaleMale" & "GreglandCuba" & end
  66 + print (run (makeSpy greg) <> run (makeSpy tony))
57 67 -- Nothing
58 68

No commit comments for this range

Something went wrong with that request. Please try again.