atoms.hs

{-# OPTIONS -Wall #-}

{-# LANGUAGE FlexibleContexts #-}                -- not all of these are needed
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}                   -- really
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}                  -- don't get scared
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE MagicHash #-}

import GHC.TypeLits
import GHC.OverloadedLabels
import GHC.Prim

----------------------------------------------------------------------------
-- main
----------------------------------------------------------------------------

main :: IO ()
main = say #hi >> say #bye

say :: OneOf ["hi", "bye"] -> IO ()
say (#hi  -> True) = putStrLn "Hello world!"
say (#bye -> True) = putStrLn "Goodbye!"

----------------------------------------------------------------------------
-- Implementation
----------------------------------------------------------------------------

instance {-# OVERLAPPING #-}
    IsLabel name (OneOf (name : xs)) where
  fromLabel _ = OneOf 0

-- TODO: can be optimized to O(1) by doing all the work at the typelevel
instance {-# OVERLAPPABLE #-}
    IsLabel name (OneOf xs) => IsLabel name (OneOf (y : xs)) where
  fromLabel _ = let OneOf n = fromLabel @name @(OneOf xs) proxy#
                in  OneOf (n+1)

instance IsLabel name (OneOf xs) => IsLabel name (OneOf xs -> Bool) where
  fromLabel _ = (== fromLabel @name @(OneOf xs) proxy#)

data OneOf (names :: [Symbol]) = OneOf Int
  deriving Eq

{-
data Atom (name :: Symbol) = Atom

instance IsLabel name (Atom name) where
  fromLabel _ = Atom
-}