sing.hs

sing.hs

@@ -0,0 +1,49 @@
+{-# language GHC2024, AllowAmbiguousTypes, TypeAbstractions #-}
+-- AllowAmbiguousTypes for dispatch :: Dispatchable d => String
+
+import System.Environment
+
+main = do
+  [s] <- getArgs
+  putStrLn $ maybe "not found" dispatchDyn $ fromString s
+
+
+data Mode = A | B
+
+data SMode m where SA :: SMode A; SB :: SMode B
+
+class KnownMode m where knownMode :: SMode m
+instance KnownMode A where knownMode = SA
+instance KnownMode B where knownMode = SB
+
+
+withMode :: Mode -> (forall m. KnownMode m => r) -> r
+withMode A f = f @A
+withMode B f = f @B
+
+
+fromString :: String -> Maybe Mode
+fromString "a" = Just A
+fromString "b" = Just B
+fromString _   = Nothing
+
+
+class Dispatchable d where dispatch :: String
+instance Dispatchable A where dispatch = "A"
+instance Dispatchable B where dispatch = "B"
+
+dispatchDyn :: Mode -> String
+dispatchDyn m = withMode m $ \ @m -> dispatch @m \\ allModesDispatchable @m
+
+
+allModesDispatchable :: KnownMode m :- Dispatchable m
+allModesDispatchable @m =
+  Sub $ case knownMode @m of SA -> Dict; SB -> Dict
+
+
+-- this stuff taken from the `constraints` package
+data Dict c = c => Dict
+data c :- d = Sub (c => Dict d)
+
+(\\) :: c => (d => r) -> c :- d -> r
+r \\ Sub Dict = r