FizzBuzz in Haskell

FizzBuzz.hs

{-# LANGUAGE NoStarIsType #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds #-}

module FizzBuzz where
import Data.Maybe
import Data.Kind
import GHC.TypeLits
import Data.Proxy

type family ReplaceEvery (n :: Nat) (s :: Symbol) :: [Maybe Symbol] where
  ReplaceEvery 0 s = TypeError (Text "Cannot replace every value with frequency 0")
  ReplaceEvery 1 s = '[Just s]
  ReplaceEvery n s = Nothing : ReplaceEvery (n - 1) s

type family Length (xs :: [a]) :: Nat where
  Length '[] = 0
  Length (x:xs) = 1 + (Length xs)

type family CycleTo' (n :: Nat) (originalList :: [a]) (currentHead :: [a]) :: [a] where
  CycleTo' 0 _ _ = '[]
  CycleTo' n orig (x:xs) = x : CycleTo' (n - 1) orig xs
  CycleTo' n orig '[] = CycleTo' n orig orig

type family CycleTo (n :: Nat) (l :: [a]) :: [a] where
  CycleTo n l = CycleTo' n l '[]

data Branch a
  = Then a
  | Else a

type family If (p :: Bool) (true :: Branch a) (false :: Branch a) :: a where
  If True ('Then true) _ = true
  If False _ ('Else false) = false

data Pair a b = Pair a b

type family PairFst (p :: Pair a b) :: a where
  PairFst ('Pair a b) = a

type family PairSnd (p :: Pair a b) :: b where
  PairSnd ('Pair a b) = b

type family SameSize (xs :: [a]) (ys :: [b]) :: Pair [a] [b] where
  SameSize xs ys =
    If (Length xs <=? Length ys)
      (Then ('Pair (CycleTo (Length ys) xs) ys))
      (Else ('Pair xs (CycleTo (Length xs) ys)))

type family EQ a b :: Bool where
  EQ a a = True
  EQ a b = False

type family CommonLength (xs :: [a]) (ys :: [b]) :: Nat where
  CommonLength xs ys =
    If (EQ (Length xs) (Length ys))
      (Then (Length xs))
      (Else ((Length xs) * (Length ys)))

type family ToMultiple (xs :: [a]) (ys :: [b]) :: Pair [a] [b] where
  ToMultiple xs ys =
    'Pair (CycleTo (CommonLength xs ys) xs) (CycleTo (CommonLength xs ys) ys)

type family JoinOptionalSymbols (a :: Maybe Symbol) (b :: Maybe Symbol) :: Maybe Symbol where
  JoinOptionalSymbols Nothing Nothing = Nothing
  JoinOptionalSymbols (Just a) Nothing = Just a
  JoinOptionalSymbols Nothing (Just b) = Just b
  JoinOptionalSymbols (Just a) (Just b) = Just (AppendSymbol a b)

type family MergeReplacers' (a :: [Maybe Symbol]) (b :: [Maybe Symbol]) :: [Maybe Symbol] where
  MergeReplacers' '[] '[] = '[]
  MergeReplacers' (a:as) (b:bs) = (JoinOptionalSymbols a b) : MergeReplacers' as bs

type family MergeReplacers (a :: [Maybe Symbol]) (b :: [Maybe Symbol]) :: [Maybe Symbol] where
  MergeReplacers as bs = MergeReplacers' (PairFst (ToMultiple as bs)) (PairSnd (ToMultiple as bs))

type family FoldReplacers (replacers :: [[Maybe Symbol]]) :: [Maybe Symbol] where
  FoldReplacers '[] = '[]
  FoldReplacers '[x] = x
  FoldReplacers (x:xs) = MergeReplacers x (FoldReplacers xs)

type family FromMaybe (val :: a) (m :: Maybe a) :: a where
  FromMaybe _ (Just a) = a
  FromMaybe a Nothing = a

type family NatSymbol (n :: Nat) :: Symbol where
  NatSymbol 0 = "0"
  NatSymbol 1 = "1"
  NatSymbol 2 = "2"
  NatSymbol 3 = "3"
  NatSymbol 4 = "4"
  NatSymbol 5 = "5"
  NatSymbol 6 = "6"
  NatSymbol 7 = "7"
  NatSymbol 8 = "8"
  NatSymbol 9 = "9"
  NatSymbol n =
    AppendSymbol (NatSymbol (Div n 10)) (NatSymbol (Mod n 10))

type family AppendToList (val :: a) (lst :: [a]) :: [a] where
  AppendToList a '[] = '[a]
  AppendToList a (x:xs) = x : (AppendToList a xs)

type family NumSymbolsTo (n :: Nat) :: [Symbol] where
  NumSymbolsTo 0 = '[]
  NumSymbolsTo n = AppendToList (NatSymbol n) (NumSymbolsTo (n - 1))

type family MergeMaybe' (defaults :: [a]) (overlays :: [Maybe a]) :: [a] where
  MergeMaybe' '[] '[] = '[]
  MergeMaybe' (a:as) (Nothing:overlays) = a : MergeMaybe' as overlays
  MergeMaybe' (_:as) ((Just overlay):overlays) = overlay : MergeMaybe' as overlays

type family MergeMaybe (defaults :: [a]) (overlays :: [Maybe a]) :: [a] where
  MergeMaybe defaults overlays = MergeMaybe' defaults (CycleTo (Length defaults) overlays)

type family UnlinesSymbols (lines :: [Symbol]) :: Symbol where
  UnlinesSymbols '[] = ""
  UnlinesSymbols (line:lines) = AppendSymbol (AppendSymbol line "\n") (UnlinesSymbols lines)

type family FizzBuzz (n :: Nat) :: Symbol where
  FizzBuzz n =
    UnlinesSymbols (MergeMaybe (NumSymbolsTo n) (FoldReplacers [ReplaceEvery 3 "fizz", ReplaceEvery 5 "buzz"]))

fizzBuzz :: forall (n :: Nat). (KnownSymbol (FizzBuzz n)) => String
fizzBuzz = symbolVal $ Proxy @(FizzBuzz n)

this is the most overengineered fizzbuzz that i have ever seen