sing.hs with TH

Dispatchable.hs

@@ -0,0 +1,32 @@
+{-# language GHC2024, AllowAmbiguousTypes, TemplateHaskell, TypeAbstractions #-}
+
+module Dispatchable where
+
+import GHC.TypeLits
+import Language.Haskell.TH
+
+
+data Dict c = c => Dict
+
+-- since TH needs to run code during compilation it introduces order-dependence.
+-- declaration splices split the file up into chunks that are checked
+-- separately, and `reify` (for example) can only see chunks that have already
+-- been done. so that `pure []` is to cause `Dispatchable` to be processed and
+-- be visible
+
+class Dispatchable d where dispatch :: String
+instance Dispatchable "a" where dispatch = "A"
+instance Dispatchable "b" where dispatch = "B"
+
+pure []
+
+data DispatchableInstance = forall s. DI (SSymbol s) (Dict (Dispatchable s))
+
+instances :: Q Exp
+instances = do
+  ClassI _ insts <- reify ''Dispatchable
+  listE $ map fromInstance insts
+ where
+  fromInstance :: Dec -> Q Exp
+  fromInstance (InstanceD _ _ (AppT _ str) _) =
+    [| DI (SSymbol @($(pure str))) Dict |]

sing.hs

@@ -1,18 +1,27 @@
-{-# language GHC2024, AllowAmbiguousTypes, TypeAbstractions #-}
+{-# language GHC2024, AllowAmbiguousTypes, TemplateHaskell, TypeAbstractions #-}
+
+import Dispatchable
+-- due to TH's staging restriction (cannot splice definitions from the same
+-- file), the dispatchable stuff has to be separated out
 
 import Data.Maybe
 import Data.Type.Equality
 import GHC.TypeLits
 import System.Environment
 
-main = do
-  [s] <- getArgs
-  putStrLn $ fromMaybe "some default value" $ dispatchDyn s
 
+stringDispatchableWith :: KnownSymbol m =>
+                          [DispatchableInstance] -> Maybe (Dict (Dispatchable m))
+stringDispatchableWith @_ [] = Nothing
+stringDispatchableWith @m (DI (SSymbol @s) Dict : insts)
+  | Just Refl <- is @s @m = Just Dict
+  | otherwise = stringDispatchableWith @m insts
+  where is :: (KnownSymbol a, KnownSymbol b) => Maybe (a :~: b)
+        is @a @b = sameSymbol (SSymbol @a) (SSymbol @b)
+
+stringDispatchable :: KnownSymbol m => Maybe (Dict (Dispatchable m))
+stringDispatchable = stringDispatchableWith $instances
 
-class Dispatchable d where dispatch :: String
-instance Dispatchable "a" where dispatch = "A"
-instance Dispatchable "b" where dispatch = "B"
 
 dispatchDyn :: String -> Maybe String
 dispatchDyn m = withSomeSSymbol m $ \(SSymbol @m) ->
@@ -21,13 +30,6 @@ dispatchDyn m = withSomeSSymbol m $ \(SSymbol @m) ->
     Nothing   -> Nothing
 
 
-stringDispatchable :: KnownSymbol m => Maybe (Dict (Dispatchable m))
-stringDispatchable @m
-  | Just Refl <- is @"a" @m = Just Dict
-  | Just Refl <- is @"b" @m = Just Dict
-  | otherwise = Nothing
-  where is :: (KnownSymbol a, KnownSymbol b) => Maybe (a :~: b)
-        is @a @b = sameSymbol (SSymbol @a) (SSymbol @b)
-
-
-data Dict c = c => Dict
+main = do
+  [s] <- getArgs
+  putStrLn $ fromMaybe "some default value" $ dispatchDyn s