module SuperRecord
(
(:=)(..)
, Record, rnil, rcons, (&)
, fld
, Has, HasOf
, get, (&.)
, set
, modify
, getPath, setPath, modifyPath, RecApplyPath, (:&), (&:), (&:-)
, combine, (++:), RecAppend
, reflectRec, reflectRecFold, RecApply(..)
, FromNative, fromNative
, ToNative, toNative
, asksR, asksRP
, getsR, setsR, modifiesR
, getsRP, setsRP, modifiesRP
, lens
, Rec
, RecCopy
, RecTyIdxH
, showRec, RecKeys(..), recKeys
, RecEq(..)
, recToValue, recToEncoding
, recJsonParser, RecJsonParse(..)
, RecNfData(..)
, RecSize, RemoveAccessTo
, FldProxy(..), RecDeepTy
, KeyDoesNotExist
)
where
import Control.DeepSeq
import Control.Monad.Reader
import Data.Aeson
import Data.Aeson.Types (Parser)
import Data.Constraint
import Data.Proxy
import Data.Typeable
import GHC.Base (Int(..))
import GHC.Generics
import GHC.IO ( IO(..) )
import GHC.OverloadedLabels
import GHC.Prim
import GHC.TypeLits
import System.IO.Unsafe (unsafePerformIO)
import qualified Control.Monad.State as S
import qualified Data.Text as T
data label := value = KnownSymbol label => FldProxy label := !value
deriving instance Typeable (:=)
deriving instance Typeable (label := value)
infix 6 :=
instance (Eq value) => Eq (label := value) where
(_ := x) == (_ := y) = x == y
instance (Ord value) => Ord (label := value) where
compare (_ := x) (_ := y) = x `compare` y
instance (Show t) =>
Show (l := t) where
showsPrec p (l := t) =
showParen (p > 10) (showString ("#" ++ symbolVal l ++ " := " ++ show t))
data FldProxy (t :: Symbol)
= FldProxy
deriving (Show, Read, Eq, Ord, Typeable)
instance l ~ l' => IsLabel (l :: Symbol) (FldProxy l') where
fromLabel _ = FldProxy
type Record lts = Rec (Sort lts)
data Rec (lts :: [*])
= Rec { _unRec :: SmallArray# Any }
instance (RecApply lts lts Show) => Show (Rec lts) where
show = show . showRec
instance RecEq lts lts => Eq (Rec lts) where
(==) (a :: Rec lts) (b :: Rec lts) = recEq a b (Proxy :: Proxy lts)
instance
( RecApply lts lts ToJSON
) => ToJSON (Rec lts) where
toJSON = recToValue
toEncoding = recToEncoding
instance (RecSize lts ~ s, KnownNat s, RecJsonParse lts) => FromJSON (Rec lts) where
parseJSON = recJsonParser
instance RecNfData lts lts => NFData (Rec lts) where
rnf = recNfData (Proxy :: Proxy lts)
rnil :: Rec '[]
rnil = unsafeRnil 0
unsafeRnil :: Int -> Rec '[]
unsafeRnil (I# n#) =
unsafePerformIO $! IO $ \s# ->
case newSmallArray# n# (error "No Value") s# of
(# s'#, arr# #) ->
case unsafeFreezeSmallArray# arr# s'# of
(# s''#, a# #) -> (# s''# , Rec a# #)
rcons ::
forall l t lts s.
( RecSize lts ~ s
, KnownNat s
, KnownNat (RecVecIdxPos l (Sort (l := t ': lts)))
, KeyDoesNotExist l lts
, RecCopy lts lts (Sort (l := t ': lts))
)
=> l := t -> Rec lts -> Rec (Sort (l := t ': lts))
rcons (_ := val) lts =
unsafePerformIO $! IO $ \s# ->
case newSmallArray# newSize# (error "No value") s# of
(# s'#, arr# #) ->
case recCopyInto (Proxy :: Proxy lts) lts (Proxy :: Proxy (Sort (l := t ': lts))) arr# s'# of
s''# ->
case writeSmallArray# arr# setAt# (unsafeCoerce# val) s''# of
s'''# ->
case unsafeFreezeSmallArray# arr# s'''# of
(# s''''#, a# #) -> (# s''''#, Rec a# #)
where
!(I# setAt#) =
fromIntegral (natVal' (proxy# :: Proxy# (RecVecIdxPos l (Sort (l := t ': lts)))))
newSize# = size# +# 1#
!(I# size#) = fromIntegral $ natVal' (proxy# :: Proxy# s)
class RecCopy (pts :: [*]) (lts :: [*]) (rts :: [*]) where
recCopyInto ::
Proxy pts -> Rec lts -> Proxy rts
-> SmallMutableArray# RealWorld Any
-> State# RealWorld
-> State# RealWorld
instance RecCopy '[] lts rts where
recCopyInto _ _ _ _ s# = s#
instance
( Has l rts t
, Has l lts t
, RecCopy (RemoveAccessTo l (l := t ': pts)) lts rts
) => RecCopy (l := t ': pts) lts rts where
recCopyInto _ lts prxy tgt# s# =
let lbl :: FldProxy l
lbl = FldProxy
val = get lbl lts
pNext :: Proxy (RemoveAccessTo l (l := t ': pts))
pNext = Proxy
!(I# setAt#) =
fromIntegral (natVal' (proxy# :: Proxy# (RecVecIdxPos l rts)))
in case writeSmallArray# tgt# setAt# (unsafeCoerce# val) s# of
s'# -> recCopyInto pNext lts prxy tgt# s'#
unsafeRCons ::
forall l t lts s.
(RecSize lts ~ s, KnownNat s, KeyDoesNotExist l lts)
=> l := t -> Rec lts -> Rec (l := t ': lts)
unsafeRCons (_ := val) (Rec vec#) =
unsafePerformIO $! IO $ \s# ->
case unsafeThawSmallArray# vec# s# of
(# s'#, arr# #) ->
case writeSmallArray# arr# size# (unsafeCoerce# val) s'# of
s''# ->
case unsafeFreezeSmallArray# arr# s''# of
(# s'''#, a# #) -> (# s'''#, Rec a# #)
where
!(I# size#) = fromIntegral $ natVal' (proxy# :: Proxy# s)
(&) ::
forall l t lts s.
( RecSize lts ~ s
, KnownNat s
, KnownNat (RecVecIdxPos l (Sort (l := t ': lts)))
, KeyDoesNotExist l lts
, RecCopy lts lts (Sort (l := t ': lts))
)
=> l := t -> Rec lts -> Rec (Sort (l := t ': lts))
(&) = rcons
infixr 5 &
type family Sort (lts :: [*]) where
Sort '[] = '[]
Sort (x := t ': xs) = SortInsert (x := t) (Sort xs)
type family SortInsert (x :: *) (xs :: [*]) where
SortInsert x '[] = x ': '[]
SortInsert (x := t) ((y := u) ': ys) = SortInsert' (CmpSymbol x y) (x := t) (y := u) ys
type family SortInsert' (b :: Ordering) (x :: *) (y :: *) (ys :: [*]) where
SortInsert' 'LT x y ys = x ': (y ': ys)
SortInsert' _ x y ys = y ': SortInsert x ys
type family KeyDoesNotExist (l :: Symbol) (lts :: [*]) :: Constraint where
KeyDoesNotExist l '[] = 'True ~ 'True
KeyDoesNotExist l (l := t ': lts) =
TypeError
( 'Text "Duplicate key " ':<>: 'Text l
)
KeyDoesNotExist q (l := t ': lts) = KeyDoesNotExist q lts
type RecAppend lhs rhs = RecAppendH lhs rhs rhs '[]
type family ListConcat (xs :: [*]) (ys :: [*]) :: [*] where
ListConcat '[] ys = ys
ListConcat xs '[] = xs
ListConcat (x ': xs) ys = x ': (ListConcat xs ys)
type family ListReverse (xs :: [*]) :: [*] where
ListReverse (x ': xs) = ListConcat (ListReverse xs) '[x]
ListReverse '[] = '[]
type family RecAppendH (lhs ::[*]) (rhs :: [*]) (rhsall :: [*]) (accum :: [*]) :: [*] where
RecAppendH (l := t ': lhs) (m := u ': rhs) rhsall acc = RecAppendH (l := t ': lhs) rhs rhsall acc
RecAppendH (l := t ': lhs) '[] rhsall acc = RecAppendH lhs rhsall rhsall (l := t ': acc)
RecAppendH '[] rhs rhsall acc = ListConcat (ListReverse acc) rhsall
type family RecSize (lts :: [*]) :: Nat where
RecSize '[] = 0
RecSize (l := t ': lts) = 1 + RecSize lts
type RecVecIdxPos l lts = RecSize lts RecTyIdxH 0 l lts 1
type family RecTyIdxH (i :: Nat) (l :: Symbol) (lts :: [*]) :: Nat where
RecTyIdxH idx l (l := t ': lts) = idx
RecTyIdxH idx m (l := t ': lts) = RecTyIdxH (1 + idx) m lts
RecTyIdxH idx m '[] =
TypeError
( 'Text "Could not find label "
':<>: 'Text m
)
type family RecTy (l :: Symbol) (lts :: [*]) :: k where
RecTy l (l := t ': lts) = t
RecTy q (l := t ': lts) = RecTy q lts
type family HasOf (req :: [*]) (lts :: [*]) :: Constraint where
HasOf (l := t ': req) lts = (Has l lts t, HasOf req lts)
HasOf '[] lts = 'True ~ 'True
type Has l lts v =
( RecTy l lts ~ v
, KnownNat (RecSize lts)
, KnownNat (RecVecIdxPos l lts)
)
get ::
forall l v lts.
( Has l lts v )
=> FldProxy l -> Rec lts -> v
get _ (Rec vec#) =
let !(I# readAt#) =
fromIntegral (natVal' (proxy# :: Proxy# (RecVecIdxPos l lts)))
anyVal :: Any
anyVal =
case indexSmallArray# vec# readAt# of
(# a# #) -> a#
in unsafeCoerce# anyVal
(&.) :: forall l v lts. (Has l lts v) => Rec lts -> FldProxy l -> v
(&.) = flip get
infixl 3 &.
set ::
forall l v lts.
(Has l lts v)
=> FldProxy l -> v -> Rec lts -> Rec lts
set _ !val (Rec vec#) =
let !(I# size#) = fromIntegral $ natVal' (proxy# :: Proxy# (RecSize lts))
!(I# setAt#) = fromIntegral (natVal' (proxy# :: Proxy# (RecVecIdxPos l lts)))
dynVal :: Any
!dynVal = unsafeCoerce# val
r2 =
unsafePerformIO $! IO $ \s# ->
case newSmallArray# size# (error "No value") s# of
(# s'#, arr# #) ->
case copySmallArray# vec# 0# arr# 0# size# s'# of
s''# ->
case writeSmallArray# arr# setAt# dynVal s''# of
s'''# ->
case unsafeFreezeSmallArray# arr# s'''# of
(# s''''#, a# #) -> (# s''''#, Rec a# #)
in r2
modify ::
forall l v lts.
(Has l lts v)
=> FldProxy l -> (v -> v) -> Rec lts -> Rec lts
modify lbl fun r = set lbl (fun $ get lbl r) r
data lbl :& more = FldProxy lbl :& more
infixr 8 :&
(&:) :: FldProxy q -> more -> q :& more
(&:) = (:&)
infixr 8 &:
(&:-) :: FldProxy q -> FldProxy r -> q :& FldProxy r
(&:-) = (:&)
infixr 8 &:-
fld :: FldProxy l -> FldProxy l
fld = id
type family RecDeepTy (ps :: r) (lts :: [*]) :: * where
RecDeepTy (l :& more) (l := Rec t ': lts) = RecDeepTy more t
RecDeepTy (l :& more) (l := t ': lts) = t
RecDeepTy (l :& more) (q := t ': lts) = RecDeepTy (l :& more) lts
RecDeepTy (FldProxy l) '[l := t] = t
RecDeepTy l '[l := t] = t
class RecApplyPath p x where
setPath' :: p -> (RecDeepTy p x -> RecDeepTy p x) -> Rec x -> Rec x
getPath' :: p -> Rec x -> RecDeepTy p x
instance (Has l lts t, t ~ RecDeepTy (FldProxy l) lts) => RecApplyPath (FldProxy l) lts where
setPath' = modify
getPath' = get
instance
( RecDeepTy (l :& more) lts ~ RecDeepTy more rts
, RecTy l lts ~ Rec rts
, Has l lts v
, v ~ Rec rts
, RecApplyPath more rts
) => RecApplyPath (l :& more) lts where
setPath' (x :& more) v r =
let innerVal :: Rec rts
innerVal = get x r
in set x (setPath' more v innerVal) r
getPath' (x :& more) r = getPath' more (get x r)
setPath :: RecApplyPath k x => k -> RecDeepTy k x -> Rec x -> Rec x
setPath s v = setPath' s (const v)
modifyPath :: RecApplyPath k x => k -> (RecDeepTy k x -> RecDeepTy k x) -> Rec x -> Rec x
modifyPath = setPath'
getPath :: RecApplyPath k x => k -> Rec x -> RecDeepTy k x
getPath = getPath'
combine ::
forall lhs rhs.
( KnownNat (RecSize lhs)
, KnownNat (RecSize rhs)
, KnownNat (RecSize lhs + RecSize rhs)
, RecCopy lhs lhs (Sort (RecAppend lhs rhs))
, RecCopy rhs rhs (Sort (RecAppend lhs rhs))
)
=> Rec lhs
-> Rec rhs
-> Rec (Sort (RecAppend lhs rhs))
combine lts rts =
let !(I# size#) =
fromIntegral $ natVal' (proxy# :: Proxy# (RecSize lhs + RecSize rhs))
in unsafePerformIO $! IO $ \s# ->
case newSmallArray# size# (error "No value") s# of
(# s'#, arr# #) ->
case recCopyInto (Proxy :: Proxy lhs) lts (Proxy :: Proxy (Sort (RecAppend lhs rhs))) arr# s'# of
s''# ->
case recCopyInto (Proxy :: Proxy rhs) rts (Proxy :: Proxy (Sort (RecAppend lhs rhs))) arr# s''# of
s'''# ->
case unsafeFreezeSmallArray# arr# s'''# of
(# s''''#, a# #) -> (# s''''#, Rec a# #)
(++:) ::
forall lhs rhs.
( KnownNat (RecSize lhs)
, KnownNat (RecSize rhs)
, KnownNat (RecSize lhs + RecSize rhs)
, RecCopy lhs lhs (Sort (RecAppend lhs rhs))
, RecCopy rhs rhs (Sort (RecAppend lhs rhs))
)
=> Rec lhs
-> Rec rhs
-> Rec (Sort (RecAppend lhs rhs))
(++:) = combine
data RecFields (flds :: [Symbol]) where
RFNil :: RecFields '[]
RFCons :: KnownSymbol f => FldProxy f -> RecFields xs -> RecFields (f ': xs)
recKeys :: forall t (lts :: [*]). RecKeys lts => t lts -> [String]
recKeys = recKeys' . recFields
recKeys' :: RecFields lts -> [String]
recKeys' x =
case x of
RFNil -> []
RFCons q qs -> symbolVal q : recKeys' qs
class RecKeys (lts :: [*]) where
type RecKeysT lts :: [Symbol]
recFields :: t lts -> RecFields (RecKeysT lts)
instance RecKeys '[] where
type RecKeysT '[] = '[]
recFields _ = RFNil
instance (KnownSymbol l, RecKeys lts) => RecKeys (l := t ': lts) where
type RecKeysT (l := t ': lts) = (l ': RecKeysT lts)
recFields (_ :: f (l := t ': lts)) =
let lbl :: FldProxy l
lbl = FldProxy
more :: Proxy lts
more = Proxy
in (lbl `RFCons` recFields more)
reflectRec ::
forall c r lts. (RecApply lts lts c)
=> Proxy c
-> (forall a. c a => String -> a -> r)
-> Rec lts
-> [r]
reflectRec _ f r =
reverse $
recApply (\(Dict :: Dict (c a)) s v xs -> (f s v : xs)) r (Proxy :: Proxy lts) []
reflectRecFold ::
forall c r lts. (RecApply lts lts c)
=> Proxy c
-> (forall a. c a => String -> a -> r -> r)
-> Rec lts
-> r
-> r
reflectRecFold _ f r =
recApply (\(Dict :: Dict (c a)) s v x -> f s v x) r (Proxy :: Proxy lts)
showRec :: forall lts. (RecApply lts lts Show) => Rec lts -> [(String, String)]
showRec = reflectRec @Show Proxy (\k v -> (k, show v))
recToValue :: forall lts. (RecApply lts lts ToJSON) => Rec lts -> Value
recToValue r = toJSON $ reflectRec @ToJSON Proxy (\k v -> (T.pack k, toJSON v)) r
recToEncoding :: forall lts. (RecApply lts lts ToJSON) => Rec lts -> Encoding
recToEncoding r = pairs $ mconcat $ reflectRec @ToJSON Proxy (\k v -> (T.pack k .= v)) r
recJsonParser :: forall lts s. (RecSize lts ~ s, KnownNat s, RecJsonParse lts) => Value -> Parser (Rec lts)
recJsonParser =
withObject "Record" $ \o ->
recJsonParse initSize o
where
initSize = fromIntegral $ natVal' (proxy# :: Proxy# s)
class RecApply (rts :: [*]) (lts :: [*]) c where
recApply :: (forall a. Dict (c a) -> String -> a -> b -> b) -> Rec rts -> Proxy lts -> b -> b
instance RecApply rts '[] c where
recApply _ _ _ b = b
instance
( KnownSymbol l
, RecApply rts (RemoveAccessTo l lts) c
, Has l rts v
, c v
) => RecApply rts (l := t ': lts) c where
recApply f r (_ :: Proxy (l := t ': lts)) b =
let lbl :: FldProxy l
lbl = FldProxy
val = get lbl r
res = f Dict (symbolVal lbl) val b
pNext :: Proxy (RemoveAccessTo l (l := t ': lts))
pNext = Proxy
in recApply f r pNext res
class RecEq (rts :: [*]) (lts :: [*]) where
recEq :: Rec rts -> Rec rts -> Proxy lts -> Bool
instance RecEq rts '[] where
recEq _ _ _ = True
instance
( RecEq rts (RemoveAccessTo l lts)
, Has l rts v
, Eq v
) => RecEq rts (l := t ': lts) where
recEq r1 r2 (_ :: Proxy (l := t ': lts)) =
let lbl :: FldProxy l
lbl = FldProxy
val = get lbl r1
val2 = get lbl r2
res = val == val2
pNext :: Proxy (RemoveAccessTo l (l := t ': lts))
pNext = Proxy
in res && recEq r1 r2 pNext
type family RemoveAccessTo (l :: Symbol) (lts :: [*]) :: [*] where
RemoveAccessTo l (l := t ': lts) = RemoveAccessTo l lts
RemoveAccessTo q (l := t ': lts) = (l := t ': RemoveAccessTo l lts)
RemoveAccessTo q '[] = '[]
class RecJsonParse (lts :: [*]) where
recJsonParse :: Int -> Object -> Parser (Rec lts)
instance RecJsonParse '[] where
recJsonParse initSize _ = pure (unsafeRnil initSize)
instance
( KnownSymbol l, FromJSON t, RecJsonParse lts
, RecSize lts ~ s, KnownNat s, KeyDoesNotExist l lts
) => RecJsonParse (l := t ': lts) where
recJsonParse initSize obj =
do let lbl :: FldProxy l
lbl = FldProxy
(v :: t) <- obj .: T.pack (symbolVal lbl)
rest <- recJsonParse initSize obj
pure $ unsafeRCons (lbl := v) rest
class RecNfData (lts :: [*]) (rts :: [*]) where
recNfData :: Proxy lts -> Rec rts -> ()
instance RecNfData '[] rts where
recNfData _ _ = ()
instance
( Has l rts v
, NFData v
, RecNfData (RemoveAccessTo l lts) rts
) => RecNfData (l := t ': lts) rts where
recNfData (_ :: (Proxy (l := t ': lts))) r =
let !v = get (FldProxy :: FldProxy l) r
pNext :: Proxy (RemoveAccessTo l (l := t ': lts))
pNext = Proxy
in deepseq v (recNfData pNext r)
class FromNative a lts | a -> lts where
fromNative' :: a x -> Rec lts
instance FromNative cs lts => FromNative (D1 m cs) lts where
fromNative' (M1 xs) = fromNative' xs
instance FromNative cs lts => FromNative (C1 m cs) lts where
fromNative' (M1 xs) = fromNative' xs
instance
KnownSymbol name
=> FromNative (S1 ('MetaSel ('Just name) p s l) (Rec0 t)) '[name := t]
where
fromNative' (M1 (K1 t)) = (FldProxy :: FldProxy name) := t & rnil
instance
( FromNative l lhs
, FromNative r rhs
, lts ~ Sort (RecAppend lhs rhs)
, RecCopy lhs lhs lts
, RecCopy rhs rhs lts
, KnownNat (RecSize lhs)
, KnownNat (RecSize rhs)
, KnownNat (RecSize lhs + RecSize rhs)
)
=> FromNative (l :*: r) lts where
fromNative' (l :*: r) = fromNative' l ++: fromNative' r
fromNative :: (Generic a, FromNative (Rep a) lts) => a -> Rec lts
fromNative = fromNative' . from
class ToNative a lts | a -> lts where
toNative' :: Rec lts -> a x
instance ToNative cs lts => ToNative (D1 m cs) lts where
toNative' xs = M1 $ toNative' xs
instance ToNative cs lts => ToNative (C1 m cs) lts where
toNative' xs = M1 $ toNative' xs
instance
(Has name lts t)
=> ToNative (S1 ('MetaSel ('Just name) p s l) (Rec0 t)) lts
where
toNative' r =
M1 $ K1 (get (FldProxy :: FldProxy name) r)
instance
( ToNative l lts
, ToNative r lts
)
=> ToNative (l :*: r) lts where
toNative' r = toNative' r :*: toNative' r
toNative :: (Generic a, ToNative (Rep a) lts) => Rec lts -> a
toNative = to . toNative'
asksR :: (Has lbl lts v, MonadReader (Rec lts) m) => FldProxy lbl -> m v
asksR f = asks (get f)
asksRP :: (RecApplyPath k x, MonadReader (Rec x) m) => k -> m (RecDeepTy k x)
asksRP p = asks (getPath p)
getsR :: (Has lbl lts v, S.MonadState (Rec lts) m) => FldProxy lbl -> m v
getsR f = S.gets (get f)
setsR :: (Has lbl lts v, S.MonadState (Rec lts) m) => FldProxy lbl -> v -> m ()
setsR f v = S.modify (set f v)
modifiesR :: (Has lbl lts v, S.MonadState (Rec lts) m) => FldProxy lbl -> (v -> v) -> m ()
modifiesR f go = S.modify (modify f go)
getsRP :: (RecApplyPath k x, S.MonadState (Rec x) m) => k -> m (RecDeepTy k x)
getsRP p = S.gets (getPath p)
setsRP :: (RecApplyPath k x, S.MonadState (Rec x) m) => k -> RecDeepTy k x -> m ()
setsRP p v = S.modify (setPath p v)
modifiesRP ::(RecApplyPath k x, S.MonadState (Rec x) m) => k -> (RecDeepTy k x -> RecDeepTy k x) -> m ()
modifiesRP p go = S.modify (modifyPath p go)
type Lens s t a b = forall f. Functor f => (a -> f b) -> (s -> f t)
lens ::
Has l lts v => FldProxy l -> Lens (Rec lts) (Rec lts) v v
lens lbl f r =
fmap (\v -> set lbl v r) (f (get lbl r))