This commit is contained in:
rhiannon morris 2025-01-09 18:07:00 +01:00
parent 9e17027db8
commit 79d536cb17

49
sing.hs Normal file
View file

@ -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