stack ghci example-vinyl

-- construct a value
data Rec :: (u -> *) -> [u] -> * where
  RNil :: Rec f '[]
  (:&) :: !(f r) -> !(Rec f rs) -> Rec f (r ': rs)

infixr 7 :&

λ → type X = '[ Char, Int ]
λ → Identity 'a' :& Identity 1 :& RNil :: Rec Identity X
{Identity 'a', Identity 1}

λ → type X = '[ Char, Int ]
λ → let x = Identity 'a' :& Identity 1 :& RNil :: Rec Identity X
λ → :{
λ ‖ extractInt :: (Int ∈ rs) => Rec f rs -> f Int
λ ‖ extractInt = view (rlens Proxy)
λ ‖ :}
λ → extractInt x
Identity 1

-- prove multiple types are in a Rec
type family RImage (rs :: [k]) (ss :: [k]) :: [Nat] where
  RImage '[] ss = '[]
  RImage (r ': rs) ss = RIndex r ss ': RImage rs ss

class is ~ RImage rs ss => RSubset rs ss is where
  rsubset :: Lens' (Rec f ss) (Rec f rs) -- no proxy, inferred for each type

-- instances are defined using rlens for each element in
-- the subset

type (⊆) rs ss = RSubset rs ss (RImage rs ss)

λ → type X = '[ Char, Int ]
λ → let x = Identity 'a' :& Identity 1 :& RNil :: Rec Identity X
λ → type A = '[ Char ]
λ → :{
λ ‖ projectA :: (A ⊆ rs) => Rec f rs -> Rec f A
λ ‖ projectA = view rsubset
λ ‖ :}
λ → projectA x
{Identity 'a'}

-- prove two Recs are the same
type REquivalent rs ss is js = (RSubset rs ss is, RSubset ss rs js)

type (≅) rs ss = REquivalent rs ss (RImage rs ss) (RImage ss rs)

λ → type X = '[ Char, Int ]
λ → let x = Identity 'a' :& Identity 1 :& RNil :: Rec Identity X
λ → type X' = '[ Int, Char ]
λ → :{
λ ‖ reorder :: (a ≅ b) => Rec f a -> Rec f b
λ ‖ reorder = view rsubset
λ ‖ :}
λ → reorder x :: Rec Identity X'
{Identity 1, Identity 'a'}
λ → reorder (reorder x :: Rec Identity X') :: Rec Identity X
{Identity 'a', Identity 1}

rtraverse
  :: Applicative h
     => (forall x. f x -> h (g x)) 
     -> Rec f rs -> h (Rec g rs)

λ → type X = '[ Char, Int ]
λ → let x = Identity 'a' :& Identity 1 :& RNil :: Rec Identity X
λ → :{
λ ‖ justInside :: Functor f => f x -> f (Maybe x)
λ ‖ justInside = map Just
λ ‖ 
λ ‖ justOutside :: Functor f => f x -> Maybe (f x)
λ ‖ justOutside = Just
λ ‖ :}
λ → rtraverse justInside x
Identity {Just 1, Just 'a'}
λ → rtraverse justOutside x
Just {Identity 1, Identity 'a'}

-- base types here
newtype Username = Username Text deriving Show
newtype Password = Password Text deriving Show
newtype Email = Email Text deriving Show

-- a regular user has a username and password, but no email
type User = '[Username, Password]
type RegisteredUser = '[Email, Username, Password]

newtype Username = Username Text deriving Show
newtype Password = Password Text deriving Show
newtype Email = Email Text deriving Show

type User = '[Username, Password]
type RegisteredUser = '[Email, Username, Password]

λ → :kind! Username ∈ RegisteredUser
Username ∈ RegisteredUser :: Constraint 
= RElem Username RegisteredUser ('S 'Z)

λ → :kind! User ⊆ RegisteredUser
User ⊆ RegisteredUser :: Constraint 
= RSubset User RegisteredUser '['S 'Z, 'S ('S 'Z)]

λ → :kind! RegisteredUser ⊆ User
RegisteredUser ⊆ User :: Constraint
= RSubset RegisteredUser User '['S ('S (RIndex Email '[])), 'Z, 'S 'Z]

λ → type User2 = '[Password, Username] -- reordered
λ → :kind! User ≅ User2
User ≅ User2 :: Constraint
= REquivalent User User2 '['S 'Z, 'Z] '['S 'Z, 'Z]

-- base types here
newtype Username = Username Text
newtype Password = Password Text
newtype Email = Email Text

-- a regular user has a username and password, but no email
type User = '[Username, Password]
type RegisteredUser = '[Email, Username, Password]

λ → :{
λ ‖ verifyField :: Maybe x -> Maybe (Identity x)
λ ‖ verifyField = map Identity
λ ‖
λ ‖ verifyUser :: Rec Maybe User -> Maybe (Rec Identity User)
λ ‖ verifyUser = rtraverse verifyField
λ ‖ :}
λ → let goodUser = Just (Username "dan") :& Just (Password "*****") :& RNil
λ → verifyUser goodUser
Just {Identity (Username "dan"), Identity (Password "*****")}
λ → let badUser = Nothing :& Just (Password "*****") :& RNil
λ → verifyUser badUser
Nothing

newtype (s :: Symbol) :-> a = Val { getVal :: a }

pattern (:*:) :: a -> Rec Identity rs -> Rec Identity ((s :-> a) ': rs)

pattern (:^:) :: Functor f => f a -> Rec f rs -> Rec f ((s :-> a) ': rs)

type Record = Rec Identity

λ → type X = '[ "foo" :-> Char, "bar" :-> Int ]
λ → 
λ → 'a' :*: 1 :*: RNil :: Record X
{Identity foo :-> 'a', Identity bar :-> 1}
λ → 
λ → Just 'a' :^: Nothing :^: RNil :: Rec Maybe X
{Just foo :-> 'a', Nothing}
λ → 
λ → $(withLensesAndProxies [d| type FFoo = "foo" :-> Char |])
λ → -- lots of lenses, except GHCi doesn't do TH well ;P

import qualified Data.Aeson.BetterErrors as ABE

-- Parse is a Monad with a failure type `e` and a success type `a`
newtype FromField e a =
  FromField { unFromField :: Text -> ABE.Parse e a }

-- a class for parsing a record
class RecordFromJson rs where
  recordFromJson :: Rec (FromField e) rs -> ABE.Parse e (Rec Identity rs)

import qualified Data.Aeson.BetterErrors as ABE

newtype FromField e a =
  FromField { unFromField :: Text -> ABE.Parse e a }

-- a class for parsing a record
class RecordFromJson rs where
  recordFromJson :: Rec (FromField e) rs -> ABE.Parse e (Rec Identity rs)

-- inductively define a type class by defining the base case...
instance RecordFromJson '[] where
  recordFromJson _ = pure RNil

-- inductively define a type class by defining the base case...
instance RecordFromJson '[] where
  recordFromJson _ = pure RNil

import qualified Data.Aeson.BetterErrors as ABE

newtype FromField e a =
  FromField { unFromField :: Text -> ABE.Parse e a }

-- a class for parsing a record
class RecordFromJson rs where
  recordFromJson :: Rec (FromField e) rs -> ABE.Parse e (Rec Identity rs)

-- inductively define a type class by defining the base case...
instance RecordFromJson '[] where
  recordFromJson _ = pure RNil

-- inductively define a type class by defining the base case...
instance RecordFromJson '[] where
  recordFromJson _ = pure RNil

-- ...and the n + 1 case
instance forall s a rs. (KnownSymbol s, RecordFromJson rs)
  => RecordFromJson (s :-> a ': rs) where
  recordFromJson (FromField aFromField :& fs) =
    (:&)
      <$> (Identity <$> aFromField (pack . symbolVal $ (Proxy :: Proxy s)))
      <*> recordFromJson fs

import qualified Data.Aeson.BetterErrors as ABE

newtype Username = Username Text deriving Show
newtype Password = Password Text deriving Show
newtype Email = Email Text deriving Show

-- same as before, but with `:->` now
type RegisteredUser = '[ "user" :-> Username
                       , "password" :-> Password
                       , "email" :-> Email
                       ]

objectKeyAsText :: FromField Text Text
objectKeyAsText = FromField $ \ x -> ABE.key x ABE.asText

registeredUserRecordFromJson :: Rec (FromField Text) RegisteredUser
registeredUserRecordFromJson =
  (Username <$> objectKeyAsText)
    :^: (Password <$> objectKeyAsText)
    :^: (Email <$> objectKeyAsText)
    :^: RNil 

λ → fromJson = recordFromJson registeredUserRecordFromJson 
λ → good = "{\"user\": \"dan\", \"password\": \"*****\", \"email\": \"dan@dan.dan\"}"
λ → ABE.parse fromJson good
Right { Identity user :-> (Username "dan")
      , Identity password :-> (Password "*****")
      , Identity email :-> (Email "dan@dan.dan") }
λ → 
λ → missingEmail = "{\"user\": \"dan\", \"password\": \"*****\"}"
λ → ABE.parse fromJson missingEmail
Left (BadSchema [] (KeyMissing "email"))
λ → 
λ → badUsername = "{\"user\": 1, \"password\": \"*****\", \"email\": \"dan@dan.dan\"}"
λ → ABE.parse fromJson badUsername
Left (BadSchema [ObjectKey "user"] (WrongType TyString (Number 1.0)))