poly-labels.purs

module Main where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, logShow)
import Data.Either (Either(..))
import Data.Lens (Prism, Lens, over, prism, lens)

data Label (l :: Symbol) = Label

data HNil = HNil

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

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) (HCons l c b) a c
head = lens (\(HCons h _) -> h) \(HCons _ t) h -> HCons h t

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

class HasField l s t a b | l s -> a, l b -> t where
  field :: Label l -> Lens s t a b

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

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

data HVoid

data HEither (l :: Symbol) head tail
  = Is head
  | Isnt tail

instance showHVoid :: Show HVoid where
  show _ = "HVoid"

instance showHEither :: (Show a, Show b) => Show (HEither l a b) where
  show (Is a) = "(Is " <> show a <> ")"
  show (Isnt a) = "(Isnt " <> show a <> ")"

is :: forall l a b c. Prism (HEither l a b) (HEither l c b) a c
is = prism Is $
       case _ of
         Is h -> Right h
         Isnt b -> Left (Isnt b)

isn't :: forall l a b c. Prism (HEither l a b) (HEither l a c) b c
isn't = prism Isnt $
          case _ of
            Isnt t -> Right t
            Is b -> Left (Is b)

class HasCtor l s t a b | l s -> a, l b -> t where
  ctor :: Label l -> Prism s t a b

instance hasCtorIs :: HasCtor l (HEither l head1 tail) (HEither l head2 tail) head1 head2 where
  ctor _ = is

instance hasCtorIsn't :: HasCtor l s t a b => HasCtor l (HEither l1 head s) (HEither l1 head t) a b where
  ctor l = ctor l >>> isn't

polymorphicUpdate label = over (field label) (_ + 1)

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

      var :: HEither "foo" String (HEither "bar" Int HVoid)
      var = Isnt (Is 42)
  logShow rec
  logShow (over (field (Label :: Label "foo")) show rec)
  logShow var
  logShow (over (ctor (Label :: Label "bar")) (_ * 2) var)