[GHC] #8848: Warning: Rule too complicated to desugar

4 Mar 2014

      #8848: Warning: Rule too complicated to desugar
------------------------------------+-------------------------------------
       Reporter:  carter            |             Owner:
           Type:  bug               |            Status:  new
       Priority:  normal            |         Milestone:
      Component:  Compiler          |           Version:  7.8.1-rc2
       Keywords:                    |  Operating System:  Unknown/Multiple
   Architecture:  Unknown/Multiple  |   Type of failure:  None/Unknown
     Difficulty:  Unknown           |         Test Case:
     Blocked By:                    |          Blocking:
Related Tickets:                    |
------------------------------------+-------------------------------------
 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 #-}

 }}}

--
Ticket URL: http://ghc.haskell.org/trac/ghc/ticket/8848
GHC http://www.haskell.org/ghc/
The Glasgow Haskell Compiler