Pattern synonyms for compound-types

Main.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

module Main where

import Control.Lens
import GHC.TypeLits (Nat, KnownNat)

import CompoundTypes.Lazy

$(makePrisms ''Sum2)
$(makePrisms ''Sum3)

class KnownNat n => Select (n :: Nat) s a | s n -> a where
  prismN :: Prism' s a

pattern Select :: forall (n :: Nat) s a. (KnownNat n, Select n s a) => a -> s
pattern Select a <- (preview (prismN @n) -> Just a) where
        Select a = review (prismN @n) a

pattern Select1 :: Select 1 s a => a -> s
pattern Select1 a <- (preview (prismN @1) -> Just a) where
        Select1 a = review (prismN @1) a

pattern Select2 :: Select 2 s a => a -> s
pattern Select2 a <- (preview (prismN @2) -> Just a) where
        Select2 a = review (prismN @2) a

pattern Select3 :: Select 3 s a => a -> s
pattern Select3 a <- (preview (prismN @3) -> Just a) where
        Select3 a = review (prismN @3) a

instance Select 1 (Sum2 a b) a where prismN = _Sum2_1
instance Select 2 (Sum2 a b) b where prismN = _Sum2_2
instance Select 1 (Sum3 a b c) a where prismN = _Sum3_1
instance Select 2 (Sum3 a b c) b where prismN = _Sum3_2
instance Select 3 (Sum3 a b c) c where prismN = _Sum3_3

main :: IO ()
main = test1 >> test2

test1 :: IO ()
test1 = do
  let a :: Int + String = Select @1 1
      b :: Int + String = Select @2 "foo bar"

      f :: Int + String -> IO ()
      f (Select1 i) = print i
      f (Select2 s) = putStrLn s
      -- Sadly, this doesn't work on GHC 8.0:
      -- f (Select @1 i) = print i

  f a >> f b

test2 :: IO ()
test2 = do
  let a :: Int + Bool + Char = Select @1 42
      b :: Int + () + Char = Select @3 'c'
      c :: Int + () + Char = Select @2 undefined

      -- f :: Int + _ + Char -> IO ()
      f :: (Select 1 s Int, Select 3 s Char) => s -> IO ()
      f (Select1 i) = print i
      f (Select3 c) = putChar c >> putChar '\n'
      f _           = putStrLn "other"

  f a >> f b >> f c