Warning: Rule too complicated to desugar

I've a very very modest application of Specialize to fixed sized lists in some of my code which seems to trip up the specialization machinery. Is there any flags I can pass GHC to make sure it doesn't give up on these specialize calls?

is the only work around to write my own monomorphic versions and add some hand written rewrite rules?!

rc/Numerical/Types/Shape.hs:225:1: Warning:
    RULE left-hand side too complicated to desugar
      let {
        $dFunctor_a3XB :: Functor (Shape ('S 'Z))
        [LclId, Str=DmdType]
        $dFunctor_a3XB =
          Numerical.Types.Shape.$fFunctorShape @ 'Z $dFunctor_a3Rn } in
      map2
        @ a
        @ b
        @ c
        @ ('S ('S 'Z))
        (Numerical.Types.Shape.$fApplicativeShape
           @ ('S 'Z)
           (Numerical.Types.Shape.$fFunctorShape @ ('S 'Z) $dFunctor_a3XB)
           (Numerical.Types.Shape.$fApplicativeShape
              @ 'Z $dFunctor_a3XB Numerical.Types.Shape.$fApplicativeShape0))

src/Numerical/Types/Shape.hs:226:1: Warning:
    RULE left-hand side too complicated to desugar
      let {
        $dFunctor_a3XG :: Functor (Shape ('S 'Z))
        [LclId, Str=DmdType]
        $dFunctor_a3XG =
          Numerical.Types.Shape.$fFunctorShape @ 'Z $dFunctor_a3Rn } in
      let {
        $dFunctor_a3XF :: Functor (Shape ('S ('S 'Z)))
        [LclId, Str=DmdType]
        $dFunctor_a3XF =
          Numerical.Types.Shape.$fFunctorShape @ ('S 'Z) $dFunctor_a3XG } in
      map2
        @ a
        @ b
        @ c
        @ ('S ('S ('S 'Z)))
        (Numerical.Types.Shape.$fApplicativeShape
           @ ('S ('S 'Z))
           (Numerical.Types.Shape.$fFunctorShape
              @ ('S ('S 'Z)) $dFunctor_a3XF)
           (Numerical.Types.Shape.$fApplicativeShape
              @ ('S 'Z)
              $dFunctor_a3XF
              (Numerical.Types.Shape.$fApplicativeShape
                 @ 'Z $dFunctor_a3XG Numerical.Types.Shape.$fApplicativeShape0)))

the associated code (smashed into a single module ) is

{-# LANGUAGE DataKinds, GADTs, TypeFamilies,
              ScopedTypeVariables  #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Numerical.Types.Shape where

import GHC.Magic 
import Data.Data 
import Data.Typeable()

import Data.Type.Equality

import qualified Data.Monoid  as M 
import qualified Data.Functor as Fun 
import qualified  Data.Foldable as F
import qualified Control.Applicative as A 


import Prelude hiding  (foldl,foldr,init,scanl,scanr,scanl1,scanr1)




data Nat = S !Nat  | Z 
    deriving (Eq,Show,Read,Typeable,Data)    

#if defined(__GLASGOW_HASKELL_) && (__GLASGOW_HASKELL__ >= 707)
deriving instance Typeable 'Z
deriving instance Typeable 'S
#endif



type family n1 + n2 where
  Z + n2 = n2
  (S n1') + n2 = S (n1' + n2)
 
-- singleton for Nat
data SNat :: Nat -> * where
  SZero :: SNat Z
  SSucc :: SNat n -> SNat (S n)
 
--gcoerce :: (a :~: b) -> ((a ~ b) => r) -> r
--gcoerce Refl x = x
--gcoerce = gcastWith
 
-- inductive proof of right-identity of +
plus_id_r :: SNat n -> ((n + Z) :~: n)
plus_id_r SZero = Refl
plus_id_r (SSucc n) = gcastWith (plus_id_r n) Refl
 
-- inductive proof of simplification on the rhs of +
plus_succ_r :: SNat n1 -> Proxy n2 -> ((n1 + (S n2)) :~: (S (n1 + n2)))
plus_succ_r SZero _ = Refl
plus_succ_r (SSucc n1) proxy_n2 = gcastWith (plus_succ_r n1 proxy_n2) Refl



type N0 = Z

type N1= S N0 

type N2 = S N1

type N3 = S N2 

type N4 = S N3

type N5 = S N4

type N6 = S N5

type N7 = S N6

type N8 = S N7  

type N9 = S N8

type N10 = S N9  



{-
Need to sort out packed+unboxed vs generic approaches
see ShapeAlternatives/ for 

-}

infixr 3 :*
    
 {-
the concern basically boils down to "will it specialize / inline well"

 -}

newtype At a = At  a
     deriving (Eq, Ord, Read, Show, Typeable, Functor)


data Shape (rank :: Nat) a where 
    Nil  :: Shape Z a
    (:*) ::  !(a) -> !(Shape r a ) -> Shape  (S r) a
        --deriving  (Show)

#if defined(__GLASGOW_HASKELL_) && (__GLASGOW_HASKELL__ >= 707)
deriving instance Typeable Shape 
#endif


instance  Eq (Shape Z a) where
    (==) _ _ = True 
instance (Eq a,Eq (Shape s a))=> Eq (Shape (S s) a )  where 
    (==)  (a:* as) (b:* bs) =  (a == b) && (as == bs )   

instance  Show (Shape Z a) where 
    show _ = "Nil"

instance (Show a, Show (Shape s a))=> Show (Shape (S s) a) where
    show (a:* as) = show a  ++ " :* " ++ show as 

-- at some point also try data model that
-- has layout be dynamicly reified, but for now
-- keep it phantom typed for sanity / forcing static dispatch.
-- NB: may need to make it more general at some future point
--data Strided r a lay = Strided {   getStrides :: Shape r a   }




{-# INLINE reverseShape #-}
reverseShape :: Shape n a -> Shape n a 
reverseShape Nil = Nil
reverseShape list = go SZero Nil list
  where
    go :: SNat n1 -> Shape n1  a-> Shape n2 a -> Shape (n1 + n2) a
    go snat acc Nil = gcastWith (plus_id_r snat) acc
    go snat acc (h :* (t :: Shape n3 a)) =
      gcastWith (plus_succ_r snat (Proxy :: Proxy n3))
              (go (SSucc snat) (h :* acc) t)



instance Fun.Functor (Shape Z) where
    fmap  = \ _ Nil -> Nil 
    --{-# INLINE fmap #-}

instance  (Fun.Functor (Shape r)) => Fun.Functor (Shape (S r)) where
    fmap  = \ f (a :* rest) -> f a :* Fun.fmap f rest 
    --{-# INLINE fmap  #-}
instance  A.Applicative (Shape Z) where 
    pure = \ _ -> Nil
    --{-# INLINE pure  #-}
    (<*>) = \ _  _ -> Nil 
    --{-# INLINE (<*>) #-}
instance  A.Applicative (Shape r)=> A.Applicative (Shape (S r)) where     
    pure = \ a -> a :* (A.pure a)
    --{-# INLINE pure #-}
    (<*>) = \ (f:* fs) (a :* as) ->  f a :* (inline (A.<*>)) fs as 
    --{-# INLINE (<*>) #-}
instance F.Foldable (Shape Z) where
    foldMap = \ _ _ -> M.mempty
    --{-# fold #-}
    foldl = \ _ init  _ -> init 
    foldr = \ _ init _ -> init 
    foldr' = \_ !init _ -> init 
    foldl' = \_ !init _ -> init   


instance (F.Foldable (Shape r))  => F.Foldable (Shape (S r)) where
    foldMap = \f  (a:* as) -> f a M.<> F.foldMap f as 
    foldl' = \f !init (a :* as) -> let   next = f  init a   in     next `seq`  F.foldl f next as 
    foldr' = \f !init (a :* as ) -> f a $!  F.foldr f init as               
    foldl = \f init (a :* as) -> let   next = f  init a  in    F.foldl f next as 
    foldr = \f init (a :* as ) -> f a $  F.foldr f init as     



--
map2 :: (A.Applicative (Shape r))=> (a->b ->c) -> (Shape r a) -> (Shape r b) -> (Shape r c )
map2 = \f l r -> A.pure f A.<*>  l  A.<*> r 
{-# SPECIALIZE map2 :: (a->b->c)-> (Shape Z a )-> Shape Z b -> Shape Z c #-}
{-# SPECIALIZE map2 :: (a->b->c)-> (Shape (S Z) a )-> Shape (S Z) b -> Shape (S Z) c #-}
{-# SPECIALIZE map2 :: (a->b->c)-> (Shape (S (S Z)) a )-> Shape (S (S Z)) b -> Shape (S (S Z)) c #-}
{-# SPECIALIZE map2 :: (a->b->c)-> (Shape (S (S(S Z))) a )-> Shape (S (S (S Z))) b -> Shape (S (S(S Z))) c #-}
-- {-# INLINABLE map2 #-}

Trac metadata

Trac field	Value
Version	7.8.1-rc2
Type	Bug
TypeOfFailure	OtherFailure
Priority	normal
Resolution	Unresolved
Component	Compiler
Test case
Differential revisions
BlockedBy
Related
Blocking
CC
Operating system
Architecture