T10139.hs

{-# LANGUAGE TypeFamilies, FlexibleInstances, FlexibleContexts, UndecidableInstances,
             MultiParamTypeClasses, FunctionalDependencies #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module T10139 where

import GHC.Exts
import Data.Monoid

class Monoid v => Measured v a | a -> v where
  _measure :: v -> a
data FingerTree v a = Dummy v a
singleton :: Measured v a => a -> FingerTree v a
singleton = undefined

class DOps a where
  plus :: a -> D a -> a

type family D a :: *
type instance D (FingerTree (Size Int, v) (Sized a)) = [Diff (Normal a)]

type family Normal a :: *

data Diff a = Add Int a

newtype Sized a = Sized a
newtype Size a = Size a

-- This works:
{-
instance (Measured (Size Int, v) (Sized a), Coercible (Normal a) (Sized a)) => DOps (FingerTree (Size Int, v) (Sized a)) where
  plus = foldr (\(Add index val) seq -> singleton ((coerce) val))
-}

-- This hangs:
instance (Measured (Size Int, v) (Sized a), Coercible (Normal a) (Sized a)) => DOps (FingerTree (Size Int, v) (Sized a)) where
  plus = foldr (flip f)
    where f _seq x = case x of
            Add _index val -> singleton ((coerce) val)