refold to compute factorial

fact.hs

{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveFunctor #-}
{-# LANGUAGE BangPatterns #-}

import Data.Functor.Foldable
import TH
import Data.List

fact1 :: Integer -> Integer
fact1 n = product [1..n]

reduceProduct [] = []
reduceProduct [x] = [x]
reduceProduct (a:b:xs) = (a*b) : reduceProduct xs

product' [] = 1
product' [x] = x
product' xs = product' (reduceProduct xs)

fact2 :: Integer -> Integer
fact2 n = product' [1..n]

data BTree = Lf Integer | T BTree BTree deriving (Show)

makePrim ''BTree

fact3 :: Integer -> Integer
fact3 i = refold cpsi apsi (1, i)
    where
        cpsi :: Base BTree Integer -> Integer
        cpsi (LfF i) = i
        cpsi (TF l r) = l * r

        apsi :: (Integer, Integer) -> Base BTree (Integer, Integer)
        apsi (f, t) | f >= t = LfF f
                    | otherwise = let r = (t + f) `div` 2 in TF (f, r) (r+1, t)
                
main :: IO ()
main = do
    print $ length $ show $ fact3 1000000