Opened 5 months ago

Closed 5 months ago

#13585 closed bug (fixed)

ala from Control.Lens.Wrapped panics

Reported by: fumieval Owned by: goldfire
Priority: highest Milestone: 8.2.1
Component: Compiler (Type checker) Version: 8.2.1-rc1
Keywords: TypeInType Cc: goldfire
Operating System: Linux Architecture: Unknown/Multiple
Type of failure: Compile-time crash or panic Test Case: typecheck/should_compile/T13585
Blocked By: Blocking:
Related Tickets: #13333 Differential Rev(s):
Wiki Page:

Description (last modified by fumieval)

Panic.hs:

module Panic where

import Control.Lens.Wrapped
import Data.Monoid

foo :: Maybe String
foo = ala Last foldMap [Just "foo"]

main.hs:

module Main where
import Panic (foo)

main :: IO ()
main = print foo
$ ghc -c -O2 Panic.hs
$ ghc -c -O2 main.hs
ghc: panic! (the 'impossible' happened)
  (GHC version 8.2.0.20170404 for x86_64-unknown-linux):
        splitTyConApp
  (Exchange (Unwrapped (Last String)) (Unwrapped (Last String)) |> <*
                                                                    -> * -> *>_N) (Maybe
                                                                                     [Char]) ((Identity |> <*
                                                                                                            -> *>_N) (Maybe
                                                                                                                        [Char]))
  Call stack:
      CallStack (from HasCallStack):
        prettyCurrentCallStack, called at compiler/utils/Outputable.hs:1134:58 in ghc:Outputable
        callStackDoc, called at compiler/utils/Outputable.hs:1138:37 in ghc:Outputable
        pprPanic, called at compiler/types/Type.hs:1105:34 in ghc:Type

Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug

The GHC version is 8134f7d4ba2c14b2f24d2f4c1f5260fcaff3304a.

Control.Lens.Wrapped is from the latest version of lens on GitHub: https://github.com/ekmett/lens/blob/9c4447de7ef57f67dbe293320d45bd8a546be522/src/Control/Lens/Wrapped.hs

Change History (15)

comment:1 Changed 5 months ago by fumieval

Description: modified (diff)

comment:2 Changed 5 months ago by simonpj

I'd love to reproduce this, but I can't seem to install lens with HEAD:

cabal install --allow-newer lens --with-ghc=/home/simonpj/5builds/HEAD-4/inplace/bin/ghc-stage2
Resolving dependencies...
Configuring comonad-5...
Failed to install comonad-5
Build log ( /home/simonpj/.cabal/logs/comonad-5.log ):
cabal: Entering directory '/tmp/cabal-tmp-55183/comonad-5'
cabal: Leaving directory '/tmp/cabal-tmp-55183/comonad-5'
cabal: Error: some packages failed to install:
adjunctions-4.3 depends on comonad-5 which failed to install.
bifunctors-5.4.1 depends on comonad-5 which failed to install.
comonad-5 failed during the configure step. The exception was:
user error ('/home/simonpj/5builds/HEAD-4/inplace/bin/ghc-stage2' exited with
an error:

/tmp/cabal-tmp-55183/comonad-5/dist/setup/setup.hs:8:31: error:
Module
‘Distribution.Package’
does not export
‘PackageName(PackageName)’
|
8 | import Distribution.Package ( PackageName(PackageName), Package,
PackageId, InstalledPackageId, packageVersion, packageName )
| ^^^^^^^^^^^^^^^^^^^^^^^^
)
free-4.12.4 depends on comonad-5 which failed to install.
kan-extensions-5.0.1 depends on comonad-5 which failed to install.
lens-4.15.1 depends on comonad-5 which failed to install.
profunctors-5.2 depends on comonad-5 which failed to install.
semigroupoids-5.1 depends on comonad-5 which failed to install.
simonpj@cam-05-unx:~/code/HEAD-4$ 

Not sure how to proceed...

comment:3 Changed 5 months ago by bgamari

pacak on #ghc has also reported this and is currently working on a more minimal reproducer.

comment:4 Changed 5 months ago by pacak

Lens.hs

{-# LANGUAGE KindSignatures, RankNTypes, TypeFamilies, MultiParamTypeClasses, FlexibleInstances,UndecidableInstances #-}

module Lens where

import Data.Monoid (First(..))
import Data.Functor.Identity

class Profunctor p where
  dimap :: (a -> b) -> (c -> d) -> p b c -> p a d
  dimap f g = lmap f . rmap g
  {-# INLINE dimap #-}

  lmap :: (a -> b) -> p b c -> p a c
  lmap f = dimap f id
  {-# INLINE lmap #-}

  rmap :: (b -> c) -> p a b -> p a c
  rmap = dimap id
  {-# INLINE rmap #-}


data Exchange a b s t = Exchange (s -> a) (b -> t)

instance Functor (Exchange a b s) where
  fmap f (Exchange sa bt) = Exchange sa (f . bt)
  {-# INLINE fmap #-}

instance Profunctor (Exchange a b) where
  dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)
  {-# INLINE dimap #-}
  lmap f (Exchange sa bt) = Exchange (sa . f) bt
  {-# INLINE lmap #-}
  rmap f (Exchange sa bt) = Exchange sa (f . bt)
  {-# INLINE rmap #-}



withIso :: AnIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
withIso ai k = case ai (Exchange id Identity) of
  Exchange sa bt -> k sa (runIdentity undefined bt)
{-# INLINE withIso #-}

type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
type Iso' s a = Iso s s a a
type AnIso s t a b = Exchange a b a (Identity b) -> Exchange a b s (Identity t)

class    (Rewrapped s t, Rewrapped t s) => Rewrapping s t
instance (Rewrapped s t, Rewrapped t s) => Rewrapping s t


instance (t ~ First b) => Rewrapped (First a) t
instance Wrapped (First a) where
    type Unwrapped (First a) = Maybe a
    _Wrapped' = iso getFirst First
    {-# INLINE _Wrapped' #-}

class Wrapped s => Rewrapped (s :: *) (t :: *)

class Wrapped s where
    type Unwrapped s :: *
    _Wrapped' :: Iso' s (Unwrapped s)

_Wrapping :: Rewrapping s t => (Unwrapped s -> s) -> Iso s t (Unwrapped s) (Unwrapped t)
_Wrapping _ = _Wrapped
{-# INLINE _Wrapping #-}

iso :: (s -> a) -> (b -> t) -> Iso s t a b
iso sa bt = dimap sa (fmap bt)
{-# INLINE iso #-}

_Wrapped :: Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped = withIso _Wrapped' $ \ sa _ -> withIso _Wrapped' $ \ _ bt -> iso sa bt
{-# INLINE _Wrapped #-}

au :: Functor f => AnIso s t a b -> ((b -> t) -> f s) -> f a
au k = withIso k $ \ sa bt f -> fmap sa (f bt)
{-# INLINE au #-}

ala :: (Functor f, Rewrapping s t) => (Unwrapped s -> s) -> ((Unwrapped t -> t) -> f s) -> f (Unwrapped s)
ala = au . _Wrapping
{-# INLINE ala #-}

Panic.hs

module Panic where

import Lens
import Data.Monoid

extractZonedTime :: Maybe ()
extractZonedTime = ala First foldMap [Nothing]

Main.hs

module Main where
import Panic (extractZonedTime)

main :: IO ()
main = print extractZonedTime

comment:5 Changed 5 months ago by pacak

compile with

#!/bin/sh

rm *.hi *.o

ghc -c Lens.hs -O
ghc -c Panic.hs -O
ghc -c Main.hs -O

comment:6 Changed 5 months ago by pacak

ghc 8.0.1: successfull compilation

ghc 8.2rc:

ghc: panic! (the 'impossible' happened)
  (GHC version 8.2.0.20170404 for x86_64-unknown-linux):
        splitTyConApp
  (Exchange (Unwrapped (First ())) (Unwrapped (First ())) |> <*
                                                              -> * -> *>_N) (Maybe
                                                                               ()) ((Identity |> <*
                                                                                                  -> *>_N) (Maybe
                                                                                                              ()))
  Call stack:
      CallStack (from HasCallStack):
        prettyCurrentCallStack, called at compiler/utils/Outputable.hs:1134:58 in ghc:Outputable
        callStackDoc, called at compiler/utils/Outputable.hs:1138:37 in ghc:Outputable
        pprPanic, called at compiler/types/Type.hs:1105:34 in ghc:Type

Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug

comment:7 Changed 5 months ago by simonpj

Cc: goldfire added
Keywords: TypeInType added
Priority: normalhighest

Thank you pacak!

Core Lint fails when compiling Panic.hs with

    Data alternative when scrutinee is not a tycon application
    Scrutinee type: (Exchange (Unwrapped (First ()))
                              (Unwrapped (First ()))
                       |> <*->*->*>_N)
                       (Maybe ())
                       ((Identity |> <*->*>_N)
                       (Maybe ()))
    Alternative: Exchange sa_a36Y bt_a36Z ->
                   Exchange
                     @ (Unwrapped (First ()))
                     @ (Unwrapped (First ()))
                     @ (First ())
                     @ (Identity (First ()))
                     (\ (x_a377 :: First ()) -> sa_a36Y (x_a377 `cast` <Co:2>))
                     ((\ (x_a377 :: Unwrapped (First ())) -> bt_a36Z x_a377)
                      `cast` <Co:36>)

Richard, this is a live example of where splitTyConApp (in CoreLint.lintCoreAlt) fails on a type that looks like

  (Exchange t1 t2 |> Refl) t3 t4

The Refl is getting in the way of the splitTyConApp.

I think we agreed to make it an invariant that no such Refl casts will exist in types. How are you getting on with making it so?

comment:8 Changed 5 months ago by pacak

Simon, compilation without -c succeeds:

% ghc Main.hs -O
[1 of 3] Compiling Lens             ( Lens.hs, Lens.o )
[2 of 3] Compiling Panic            ( Panic.hs, Panic.o )
[3 of 3] Compiling Main             ( Main.hs, Main.o )
Linking Main ...

comment:9 Changed 5 months ago by simonpj

Milestone: 8.2.1
Owner: set to goldfire

Following a conversation with Richard, I'm assigning this to him and milestoning for 8.2.1. It should be fixed automatically when he commits the changes to mkCastTy and fixes for #13333.

comment:10 Changed 5 months ago by bgamari

Status: newpatch

comment:11 Changed 5 months ago by bgamari

Version: 8.2.1-rc1

comment:12 Changed 5 months ago by goldfire

I've just confirmed that my in-flight patches fix this. I've added a regression test to that patch set.

comment:13 Changed 5 months ago by Ben Gamari <ben@…>

In 6df8bef/ghc:

Test #13585 in typecheck/should_compile/T13585

comment:14 Changed 5 months ago by goldfire

Status: patchmerge
Test Case: typecheck/should_compile/T13585

Thanks, Ben, for committing this!

comment:15 Changed 5 months ago by bgamari

Resolution: fixed
Status: mergeclosed

Merged to ghc-8.2.

Note: See TracTickets for help on using tickets.