Created
September 25, 2021 23:55
-
-
Save rebeccaskinner/22f8cc747132e25b5603043b3f0f43aa to your computer and use it in GitHub Desktop.
FizzBuzz in Haskell
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {-# 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) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
this is the most overengineered fizzbuzz that i have ever seen