Poly labels wih Fail instance

Main.purs

module Main where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log, logShow)
import Data.Newtype (class Newtype, unwrap)
import Data.Profunctor (dimap)
import Data.Profunctor.Strong (class Strong, second)
import Data.Tuple (Tuple(..), uncurry)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)

newtype Forget r a b = Forget (a -> r)
derive instance newtypeForget :: Newtype (Forget r a b) _

type Fold r s t a b = Optic (Forget r) s t a b
type Getter s t a b = Fold a s t a b
type Lens s t a b = forall p. Strong p => Optic p s t a b
type Lens' s a = Lens s s a a
type Optic p s t a b = p a b -> p s t
type Setter s t a b = Optic Function s t a b

lens :: forall s t a b. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens sa sbt = dimap sa' (uncurry sbt) <<< second
  where
    sa' s = Tuple s (sa s)

over :: forall s t a b. Setter s t a b -> (a -> b) -> s -> t
over stab = stab

view :: forall s t a b. Getter s t a b -> s -> a
view stab = unwrap $ stab (Forget id)

data Label (l :: Symbol) = Label

data HNil = HNil
data HCons (l :: Symbol) head tail = HCons head tail

instance hasfieldFail ::
  Fail ("Missing field \"" <> l <> "\" of type " <> TypeString a)
                         => HasField l HNil a where
  field _ = unsafeCoerce

infixl 6 type TypeConcat as <>

instance showHNil :: Show HNil where
  show _ = "HNil"

instance showHCons :: (Show a, Show b) => Show (HCons l a b) where
  show (HCons a b) = "(HCons " <> show a <> " " <> show b <> ")"

cons :: forall l a b. Label l -> a -> b -> HCons l a b
cons _ = HCons

infix 4 cons as :=

head :: forall l a b c. Lens' (HCons l a b) a
head = lens (\(HCons h _) -> h) \(HCons _ t) h -> HCons h t

tail :: forall l a b c. Lens' (HCons l a b) b
tail = lens (\(HCons _ t) -> t) \(HCons h _) t -> HCons h t

class HasField l s a | l s -> a where
  field :: Label l -> Lens' s a

instance hasFieldHead ::
  HasField l (HCons l head tail) head where
  field _ = head

instance hasFieldTail ::
  HasField l s a => HasField l (HCons l1 head s) a where
  field l = field l >>> tail

main :: forall e. Eff (console :: CONSOLE | e) Unit
main = do
  let foo = Label :: Label "foo"
      bar = Label :: Label "bar"
      baz = Label :: Label "baz"

      rec = foo := 1 $
            bar := 'a' $
            baz := 42.0 $
            HNil

  log (view (field (Label :: Label "myfield")) rec)