{-# OPTIONS_GHC -freduction-depth=1000 #-} 
{-# LANGUAGE 
     FlexibleContexts, FlexibleInstances, FunctionalDependencies, 
     MultiParamTypeClasses, TypeSynonymInstances, 
     TypeOperators, UndecidableInstances, TypeFamilies #-} 
module T5321Fun where

-- As the below code demonstrates, the same issues demonstrated with
-- Functional Dependencies also appear with Type Families, although less
--horribly, as their code-path seems more optimized in the current
-- constraint solver:

-- Our running example, for simplicity's sake, is a type-level map of a
-- single function. For reference, here is the code for a simple
-- value-level map of a single function.

-- > vfoo = id
-- > mapfoo (x : xs) = vfoo x : mapfoo xs
-- > mapfoo [] = []

-- Because Haskell is a lazy language, this runs in O(n) time and constant stack.

-- We now lift map to the type level, to operate over HLists.

-- First, the basic HList types

infixr 3 :*
data x :* xs = x :* xs deriving Show
data HNil = HNil deriving Show

-- Next, a large boring HList

-- Adds ten cells
addData x = i :* i :* d :* d :* s :* 
            i :* i :* d :* d :* s :* 
            x 
    where i = 1 :: Int 
          d = 1 :: Double 
          s = "" 

-- Has 70 cells. 
sampleData = addData $ addData $ addData $ addData $ addData $ 
             addData $ addData $ 
             HNil


class TFoo x where 
     type TFooFun x 
     tfoo :: x -> TFooFun x 
     tfoo = undefined

instance TFoo Int where 
    type TFooFun Int = Double
instance TFoo Double where 
    type TFooFun Double = Int
instance TFoo String where 
    type TFooFun String = String

class THMapFoo1 as where 
      type THMapFoo1Res as 
      thMapFoo1 :: as -> THMapFoo1Res as

instance (TFoo a, THMapFoo1 as) => THMapFoo1 (a :* as) where 
    type THMapFoo1Res (a :* as) = TFooFun a :* THMapFoo1Res as 
    thMapFoo1 (x :* xs) = tfoo x :* thMapFoo1 xs

instance THMapFoo1 HNil where 
    type THMapFoo1Res HNil = HNil 
    thMapFoo1 _ = HNil

-- The following, when enabled, takes ~3.5s. This demonstrates that slowdown occurs with type families as well.

testTHMapFoo1 = thMapFoo1 sampleData 

class THMapFoo2 acc as where 
      type THMapFoo2Res acc as 
      thMapFoo2 :: acc -> as -> THMapFoo2Res acc as

instance (TFoo a, THMapFoo2 (TFooFun a :* acc) as) => THMapFoo2 acc (a :* as) where 
    type THMapFoo2Res acc (a :* as) = THMapFoo2Res (TFooFun a :* acc) as 
    thMapFoo2 acc (x :* xs) = thMapFoo2 (tfoo x :* acc) xs

instance THMapFoo2 acc HNil where 
    type THMapFoo2Res acc HNil = acc 
    thMapFoo2 acc _ = acc

-- The following, when enabled, takes ~0.6s. This demonstrates that the
-- tail recursive transform fixes the slowdown with type families just as
-- with fundeps.

testTHMapFoo2 = thMapFoo2 HNil sampleData 

class THMapFoo3 acc as where 
      type THMapFoo3Res acc as 
      thMapFoo3 :: acc -> as -> THMapFoo3Res acc as

instance (THMapFoo3 (TFooFun a :* acc) as, TFoo a) => THMapFoo3 acc (a :* as) where 
    type THMapFoo3Res acc (a :* as) = THMapFoo3Res (TFooFun a :* acc) as 
    thMapFoo3 acc (x :* xs) = thMapFoo3 (tfoo x :* acc) xs

instance THMapFoo3 acc HNil where 
    type THMapFoo3Res acc HNil = acc 
    thMapFoo3 acc _ = acc

-- The following, when enabled, also takes ~0.6s. This demonstrates that,
-- unlike the fundep case, the order of type class constraints does not,
-- in this instance, affect the performance of type families.

testTHMapFoo3 = thMapFoo3 HNil sampleData