Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Open Monad dictionary with record pattern synonym (and as patterns)
{-# Language PatternSynonyms #-}
{-# Language ViewPatterns    #-}

data DMonad m = DMonad
  (forall a.   a -> m a)
  (forall a b. m a -> (a -> m b) -> m b)
  (forall a.   String -> m a)

pattern Open :: (forall a. a -> [a]) -> (forall a a'. [a] -> (a -> [a']) -> [a']) -> (forall a. String -> [a]) -> xxx
pattern Open { return, bind, fail } <- (const $ DMonad (pure @[]) (P.>>=) Control.Monad.fail -> DMonad return bind fail)

bar :: [a] -> [a]
bar a@Open{..} = do
  a' <- a
  return a'

https://ghc.haskell.org/trac/ghc/ticket/13454

https://phabricator.haskell.org/D3379

@mrkgnao
Copy link

mrkgnao commented May 17, 2017

I modified this to:

{-# LANGUAGE RecordWildCards #-}
{-# Language PatternSynonyms #-}
{-# LANGUAGE TypeApplications #-}
{-# Language ViewPatterns    #-}

import Prelude (String)
import qualified Prelude as P
import qualified Control.Monad as M

data DMonad m = DMonad
  (forall a.   a -> m a)
  (forall a b. m a -> (a -> m b) -> m b)
  (forall a.   String -> m a)

pattern Open
  :: forall m r.
     M.Monad m
  => (forall a. a -> m a)
  -> (forall a b. m a -> (a -> m b) -> m b)
  -> (forall b. String -> m b)
  -> r
pattern Open { return, bind, fail } <- (const $ DMonad (pure @m) (P.>>=) M.fail -> DMonad return bind fail)

bar :: (M.Monad m, P.Num a) => m a -> m a
bar a@Open{..} = do
  a' <- a
  return (a' + a')

And got the following compiler panic:

[1 of 1] Compiling Noether.Algebra.Subtyping ( /home/mrkgnao/code/haskell/noether/.stack-work/intero/intero12905PDH.hs, interpreted )
intero: panic! (the 'impossible' happened)
  (GHC version 8.0.2 for x86_64-unknown-linux):
	initTc: unsolved constraints
  WC {wc_insol =
        [W] $_aUd :: t_aUc[tau:3] (CHoleCan: $)
        [W] const_aUk :: t_aUj[tau:3] (CHoleCan: const)
        [W] pure_aUw :: t_aUv[tau:5] (CHoleCan: pure)}

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

(which I think is because of the pure name-clash: qualifying everything fixed the bug.)

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment