├── .gitignore ├── Benchmark.hs ├── README.md ├── benchmark-cases ├── magic │ ├── app │ │ └── Main.hs.prefix │ ├── package.yaml │ └── stack.yaml └── no-magic │ ├── app │ └── Main.hs.prefix │ ├── package.yaml │ ├── src │ └── TypeLevel │ │ └── Elem.hs │ └── stack.yaml ├── benchmark-results.png ├── package.yaml ├── src └── TypeLevel │ ├── Elem.hs │ └── Elem │ └── Plugin.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | *.cabal 2 | dist-newstyle/ 3 | .stack-work/ 4 | stack.yaml.lock 5 | benchmark-cases/*/*.cabal 6 | benchmark-cases/*/.stack-work/ 7 | benchmark-cases/*/stack.yaml.lock 8 | benchmark-cases/*/app/Main.hs 9 | -------------------------------------------------------------------------------- /Benchmark.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env cabal 2 | {- cabal: 3 | build-depends: base 4 | , directory 5 | , filepath 6 | , text 7 | , time 8 | , typed-process 9 | -} 10 | {-# LANGUAGE LambdaCase, OverloadedStrings, ScopedTypeVariables #-} 11 | 12 | import Data.Function ((&)) 13 | import Data.Time.Clock 14 | import Data.Foldable (for_) 15 | import System.Environment (getArgs, getProgName) 16 | import System.Exit (ExitCode(ExitFailure, ExitSuccess)) 17 | import System.FilePath ((<.>), ()) 18 | import System.Process.Typed (ProcessConfig) 19 | import qualified System.Directory as FilePath 20 | import qualified System.Process.Typed as Process 21 | 22 | 23 | main 24 | :: IO () 25 | main = do 26 | getArgs >>= \case 27 | [arg] | not (arg `elem` ["-h", "--help"]) -> do 28 | -- "/..." (root of the repo) 29 | let rootPath :: FilePath 30 | rootPath = arg 31 | 32 | -- "/.../benchmark-cases" 33 | let casesDir :: FilePath 34 | casesDir = rootPath "benchmark-cases" 35 | 36 | -- ["no-magic", ...] 37 | caseSubdirs <- FilePath.listDirectory casesDir 38 | 39 | for_ caseSubdirs $ \caseSubdir -> do 40 | -- "no-magic" 41 | let caseName :: String 42 | caseName = caseSubdir 43 | 44 | -- "/.../benchmark-cases/no-magic" 45 | let workingDir :: FilePath 46 | workingDir = casesDir caseSubdir 47 | 48 | -- "/.../benchmark-cases/no-magic/app/Main.hs" 49 | let mainPath :: FilePath 50 | mainPath = workingDir "app/Main.hs" 51 | 52 | -- "/.../benchmark-cases/no-magic/app/Main.hs.prefix" 53 | let mainPrefixPath :: FilePath 54 | mainPrefixPath = mainPath <.> "prefix" 55 | 56 | -- stack build 57 | let processConfig :: ProcessConfig () () () 58 | processConfig = Process.proc "stack" ["build"] 59 | & Process.setStdin Process.nullStream 60 | & Process.setStdout Process.nullStream 61 | & Process.setStderr Process.nullStream 62 | & Process.setWorkingDir workingDir 63 | 64 | let timeBuild :: Int -> IO Double 65 | timeBuild n = do 66 | startTime <- getCurrentTime 67 | mainPrefix <- lines <$> readFile mainPrefixPath 68 | let mainSuffix = 69 | [ "main = pure (unit @" ++ show n ++ " @'" ++ show [1..n] ++ ")" 70 | ] 71 | let mainCode = mainPrefix ++ mainSuffix 72 | writeFile mainPath (unlines mainCode) 73 | Process.runProcess_ processConfig 74 | finishTime <- getCurrentTime 75 | pure $ realToFrac (diffUTCTime finishTime startTime) 76 | 77 | -- warm the cache 78 | _ <- timeBuild 2 79 | 80 | -- run the benchmark 81 | putStrLn caseName 82 | for_ [100,200..2000] $ \n -> do 83 | t <- timeBuild n 84 | print (n, t) 85 | _ -> do 86 | putStrLn "usage: " 87 | putStrLn $ " ./Benchmark.hs `pwd`" 88 | putStrLn "" 89 | putStrLn "Build a few projects with larger and larger type-level lists," 90 | putStrLn "to compare the performance of various approaches." 91 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Magic Typelevel Elem 2 | 3 | Demonstrating how to make type families faster using typechecker plugins. 4 | 5 | ![plot showing that the plugin is much faster](benchmark-results.png) 6 | 7 | The type family implementation is the obvious one: 8 | 9 | ```haskell 10 | type family Elem a as where 11 | Elem a '[] = 'False 12 | Elem a (a ': as) = 'True 13 | Elem a (b ': as) = Elem a as 14 | ``` 15 | 16 | The algorithm looks linear, but for some reason the compilation time is clearly quadratic. 17 | 18 | The typechecker-plugin version of the type family has no implementation: 19 | 20 | ```haskell 21 | type family Elem a as 22 | ``` 23 | 24 | The typechecker plugin receives ghc's value-level representation of the types `n` and `'[1..n]`, computes `any (== n) (toList ns)`, and converts the resulting Bool to ghc's value-level representation of type-level booleans. 25 | 26 | The algorithm is still linear, but this time it actually runs in linear time, and the constant factors are so good that its plot looks flat compared to the type family approach! 27 | -------------------------------------------------------------------------------- /benchmark-cases/magic/app/Main.hs.prefix: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, TypeApplications #-} 2 | {-# OPTIONS_GHC -fplugin TypeLevel.Elem.Plugin #-} 3 | import TypeLevel.Elem 4 | 5 | main :: IO () 6 | -------------------------------------------------------------------------------- /benchmark-cases/magic/package.yaml: -------------------------------------------------------------------------------- 1 | name: magic 2 | version: 0.1 3 | 4 | ghc-options: -W -Wall 5 | 6 | dependencies: 7 | - base >= 4.12 && < 5 8 | - magic-typelevel-elem 9 | 10 | executables: 11 | magic: 12 | source-dirs: app 13 | main: Main 14 | -------------------------------------------------------------------------------- /benchmark-cases/magic/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.27 2 | packages: 3 | - '.' 4 | - '../..' 5 | 6 | extra-deps: 7 | - magic-tyfams-0.1.1.0 8 | -------------------------------------------------------------------------------- /benchmark-cases/no-magic/app/Main.hs.prefix: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, TypeApplications #-} 2 | {-# OPTIONS -freduction-depth=0 #-} 3 | import TypeLevel.Elem 4 | 5 | main :: IO () 6 | -------------------------------------------------------------------------------- /benchmark-cases/no-magic/package.yaml: -------------------------------------------------------------------------------- 1 | name: typelevel-elem 2 | version: 0.1 3 | 4 | ghc-options: -W -Wall 5 | 6 | dependencies: 7 | - base >= 4.12 && < 5 8 | 9 | library: 10 | source-dirs: src 11 | 12 | executables: 13 | no-magic: 14 | source-dirs: app 15 | main: Main 16 | dependencies: 17 | - typelevel-elem 18 | -------------------------------------------------------------------------------- /benchmark-cases/no-magic/src/TypeLevel/Elem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes, DataKinds, PolyKinds, TypeFamilies, TypeOperators #-} 2 | module TypeLevel.Elem where 3 | 4 | type family Elem a as where 5 | Elem a '[] = 'False 6 | Elem a (a ': as) = 'True 7 | Elem a (b ': as) = Elem a as 8 | 9 | unit :: Elem a as ~ 'True => () 10 | unit = () 11 | -------------------------------------------------------------------------------- /benchmark-cases/no-magic/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.27 2 | packages: 3 | - '.' 4 | 5 | extra-deps: [] 6 | -------------------------------------------------------------------------------- /benchmark-results.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gelisam/magic-typelevel-elem/20cbc511bbef6b0670bfb6cea23fc3995389cfb9/benchmark-results.png -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: magic-typelevel-elem 2 | version: 0.1 3 | 4 | ghc-options: -W -Wall -dcore-lint 5 | 6 | dependencies: 7 | - base 8 | 9 | library: 10 | source-dirs: src 11 | dependencies: 12 | - magic-tyfams 13 | - ghc >= 8.6.5 && < 8.7 14 | -------------------------------------------------------------------------------- /src/TypeLevel/Elem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes, DataKinds, TypeFamilies#-} 2 | module TypeLevel.Elem where 3 | 4 | import GHC.TypeLits 5 | 6 | type family Elem (a :: Nat) (as :: [Nat]) :: Bool 7 | 8 | unit :: Elem a as ~ 'True => () 9 | unit = () 10 | -------------------------------------------------------------------------------- /src/TypeLevel/Elem/Plugin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, MultiWayIf #-} 2 | {-# OPTIONS -Wno-name-shadowing #-} 3 | module TypeLevel.Elem.Plugin (plugin) where 4 | 5 | import GhcPlugins 6 | import Plugin.MagicTyFam (magicTyFamPlugin, withStuckSemantics) 7 | 8 | -- trace-debugging: 9 | --import Debug.Trace 10 | ----traceShow ("foo", showSDocUnsafe $ ppr foo) 11 | 12 | 13 | asList :: Type -> Maybe [Type] 14 | asList t = do 15 | (tyCon, args) <- splitTyConApp_maybe t 16 | if | tyCon == promotedNilDataCon -> do 17 | pure [] 18 | | tyCon == promotedConsDataCon -> do 19 | [_k, hd, tl] <- pure args 20 | (hd :) <$> asList tl 21 | | otherwise -> do 22 | Nothing 23 | 24 | plugin :: Plugin 25 | plugin = magicTyFamPlugin "typelevel-elem" 26 | "TypeLevel.Elem" 27 | "Elem" $ 28 | withStuckSemantics $ \[x, xs] -> promoteBool <$> do 29 | case asList xs of 30 | Nothing -> pure False 31 | Just xs -> pure $ any (eqType x) xs 32 | 33 | 34 | promoteBool :: Bool -> Type 35 | promoteBool = \case 36 | False -> mkTyConApp promotedFalseDataCon [] 37 | True -> mkTyConApp promotedTrueDataCon [] 38 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.27 2 | packages: 3 | - '.' 4 | 5 | extra-deps: 6 | - magic-tyfams-0.1.1.0 7 | --------------------------------------------------------------------------------