EAGLE 雑記

■[Haskell] 型エラーとして FizzBuzz を出力

GHC で以下のコードをコンパイルしようとすると，型エラーとして FizzBuzz 的なものが出力されます．

出力を見やすくしようとして Template Haskell を使ったら比較的最近の GHC でないとコンパイルできなくなってしまった…

手元の GHC (7.0.3) だと OK で，ideone の GHC (6.8.2) だとダメ*1だった．

#define N 30

のところでいくつまで出力するかを決めている．

N を大きくしたら -fcontext-stack の値も大きくしないと別のエラーが出る．

{-# LANGUAGE TypeFamilies, EmptyDataDecls, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE TemplateHaskell, CPP #-}
{-# OPTIONS_GHC -fcontext-stack=64 #-}
import Language.Haskell.TH

data Z
data S n
data Yes
data No
data Nil
data x ::: xs

type family a :<= b :: *
type instance Z :<= Z = Yes
type instance Z :<= S b = Yes
type instance S n :<= Z = No
type instance S a :<= S b = a :<= b

type family a :== b :: *
type instance Z :== Z = Yes
type instance Z :== S b = No
type instance S a :== Z = No
type instance S a :== S b = a :== b

type family a :- b :: *
type instance a :- Z = a
type instance S a :- S b = a :- b

type Divisible a b = Divisible' (a :<= b) a b
type family Divisible' t a b :: *
type instance Divisible' Yes a b = a :== b
type instance Divisible' No a b = Divisible (a :- b) b

data Fizz
data Buzz
data FizzBuzz

#define N 30
type family ToReadable x :: *
type instance ToReadable Fizz = Fizz
type instance ToReadable Buzz = Buzz
type instance ToReadable FizzBuzz = FizzBuzz
$(
  let cls = mkName "ToReadable"
      f i = let name = mkName ('N' : show i)
                nat = foldr appT (conT (mkName "Z")) $ replicate i (conT (mkName "S"))
            in [dataD (cxt []) name [] [] [], tySynInstD cls [nat] (conT name)]
  in sequence $ concatMap f [1 .. N]
  )

type ToFizzBuzz n = ToFizzBuzz' (Divisible n (S (S (S Z)))) (Divisible n (S (S (S (S (S Z)))))) n
type family ToFizzBuzz' t3 t5 n :: *
type instance ToFizzBuzz' No No n = ToReadable n
type instance ToFizzBuzz' Yes No n = Fizz
type instance ToFizzBuzz' No Yes n = Buzz
type instance ToFizzBuzz' Yes Yes n = FizzBuzz

type FizzBuzzList n = FizzBuzzList' n n
type family FizzBuzzList' n i :: *
type instance FizzBuzzList' n Z = Nil
type instance FizzBuzzList' n (S i) = (ToFizzBuzz (n :- i)) ::: (FizzBuzzList' n i)

class ShowType a where showType :: a

main =
  let _ = showType :: FizzBuzzList $(foldr appT (conT (mkName "Z")) $ replicate N (conT (mkName "S")))
  in return ()

出力例:

(snip)
    No instance for (ShowType
                       (N1
                        ::: (N2
                             ::: (Fizz
                                  ::: (N4
                                       ::: (Buzz
                                            ::: (Fizz
                                                 ::: (N7
                                                      ::: (N8
                                                           ::: (Fizz
                                                                ::: (Buzz
                                                                     ::: (N11
                                                                          ::: (Fizz
                                                                               ::: (N13
                                                                                    ::: (N14
                                                                                         ::: (FizzBuzz
                                                                                              ::: (N16
                                                                                                   ::: (N17
                                                                                                        ::: (Fizz
                                                                                                             ::: (N19
                                                                                                                  ::: (Buzz
                                                                                                                       ::: (Fizz
                                                                                                                            ::: (N22
                                                                                                                                 ::: (N23
                                                                                                                                      ::: (Fizz
                                                                                                                                           ::: (Buzz
                                                                                                                                                ::: (N26
                                                                                                                                                     ::: (Fizz
                                                                                                                                                          ::: (N28
                                                                                                                                                               ::: (N29
                                                                                                                                                                    ::: (FizzBuzz
                                                                                                                                                                         ::: Nil)))))))))))))))))))))))))))))))
      arising from a use of `showType'
(snip)

Permalink | コメント(0) | トラックバック(1) | 01:23