✨

Haskellで型レベルfizzbuzz

2023/04/08に公開

Haskell

ghc

tech

ghc-9.6.1 です。
型関数をほとんど書いたこと無かったので試しに。

{-# Language DataKinds #-}
{-# Language TypeFamilies #-}
{-# Language UndecidableInstances #-}
{-# Language TypeApplications #-}
{-# Language MagicHash #-}

import GHC.TypeLits
import GHC.Exts
import Data.Ord
import Data.Type.Bool
import Data.Type.Equality

type family FizzBuzz (n :: Nat) :: Symbol where
  FizzBuzz n =
    If (Mod n 15 == 0) "FizzBuzz"
      (If (Mod n 5 == 0) "Buzz"
        (If (Mod n 3 == 0) "Fizz" (ShowNat n)))

type family FizzBuzzList (ns :: [Nat]) :: [Symbol] where
  FizzBuzzList '[] = '[]
  FizzBuzzList (n ': ns) = (FizzBuzz n) ': FizzBuzzList ns

type family Intercalate (s :: Symbol) (ns :: [Symbol]) :: Symbol where
  Intercalate _ '[] = ""
  Intercalate delim (s ': ss) = AppendSymbol (AppendSymbol s delim) (Intercalate delim ss)

type family ConcatSymbols (ss :: [Symbol]) :: Symbol where
  ConcatSymbols ss = Intercalate "" ss

type family ShowNat (n :: Nat) :: Symbol where
  ShowNat n = ShowNat' (IsOneDigit n) n

type family ShowNat' (loopEnd :: Bool) (n :: Nat) :: Symbol where
  ShowNat' 'True n = ShowDigit n
  ShowNat' 'False n = AppendSymbol (ShowNat' (IsOneDigit (Div n 10)) (Div n 10)) (ShowDigit (Mod n 10))

type family IsOneDigit (n :: Nat) :: Bool where
  IsOneDigit n = CmpNat n 10 == 'LT

type family ShowDigit (n :: Nat) :: Symbol where
  ShowDigit 0 = "0"
  ShowDigit 1 = "1"
  ShowDigit 2 = "2"
  ShowDigit 3 = "3"
  ShowDigit 4 = "4"
  ShowDigit 5 = "5"
  ShowDigit 6 = "6"
  ShowDigit 7 = "7"
  ShowDigit 8 = "8"
  ShowDigit 9 = "9"
  ShowDigit _ = TypeError (Text "Encountered too large number")

type family NatFromTo (from :: Nat) (to :: Nat) :: [Nat] where
  NatFromTo from to = NatFromTo' (from == to) from to

type family NatFromTo' (loopEnd :: Bool) (from :: Nat) (to :: Nat) :: [Nat] where
  NatFromTo' 'True _ to = to ': '[]
  NatFromTo' 'False from to = from ': (NatFromTo' (from + 1 == to) (from + 1) to)

type family CalcFizzBuzzTo (to :: Nat) :: Symbol where
  CalcFizzBuzzTo to = Intercalate "\n" (FizzBuzzList (NatFromTo 1 to))

main = do
  putStrLn $ symbolVal' (proxy# @(CalcFizzBuzzTo 30))

型関数のbodyで型関数を呼ぶにはUndecidableInstancesが必要な様です。まあ無限ループし得るので仕方ないですね。

変なテクニック等を使わずに割と素直に型関数が書けるのですごいなーと思っていたのですが、再帰関数定義する際に無限ループが発生してそこそこ詰まりました。Haskellの型関数は先行評価で、If型関数がその名の通り関数になっている様で、then節、else節の評価が遅延してくれないからですね...
ということで先行評価でもループが終わる様にヘルパー関数(ShowNat', NatFromTo')を定義して、その1引数をbase caseへの分岐用の特別なものにしました。型レベルletとか欲しくなりますね。
まあそれ以外は素直に(シングルトンとか定義せずに)書けていい感じじゃないでしょうか。

あと型レベル高階関数は使えませんでした。Haskellに型レベル高階関数を導入する論文があるのでまあまだまだということなのでしょう:

Discussion