generalization of idiom brackets

Ii.hs

{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module VogtNoApplyAB where
import Control.Applicative
 
class InfixF a b where
  iI :: a -> b

data Ii = Ii
instance (r ~ r') => InfixF r (Ii -> r') where
  iI r Ii = r
-- or if we hate -XOverlappingInstances, and are willing to put up with
-- what might be worse type inference,
-- > instance _ => InfixF fab (f a -> r) where
instance (Applicative f, fab ~ f (a -> b), fa ~ f a,
          InfixF (f b) r) => InfixF fab (f a -> r) where
  iI fab fa = iI (fab <*> fa)

x,y,z :: Maybe Int
f = Just (,,); x = Just 1; y = Just 2; z = Just 3
g :: Maybe (Int, Int, Int)
g = iI f x y z Ii
 
h :: Maybe (Int, Int, Int)
h = iI f x y (iI x Ii) Ii 

IiWith.hs

{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module IiWith where

import Data.HList.CommonMain
import Control.Applicative

{- | this is mostly inspired by

http://hackage.haskell.org/package/uu-parsinglib-2.8.1.1/docs/Text-ParserCombinators-UU-Idioms.html#t:Idiomatic


The idea is that

> iIwith FUN x y z Ii

expands out to

> x `fun` y `fun` z

provided there is an

> instance ApplyAB FUN x y where applyAB _ = fun

-}
class InfixF f as t where
    iIwith :: f -> as -> t

data Ii = Ii

instance (as ~ as') => InfixF f as (Ii -> as') where
    iIwith f as Ii = as

instance (ApplyAB f (as,a) as', InfixF f as' b) => InfixF f as (a -> b) where
    iIwith f as a = iIwith f (applyAB f (as,a) :: as')




{- | Idiom brackets as a special case of iIwith

>>> let f = Just (,,); x = Just 1; y = Just 2; z = Just 3
>>> iI f x y z Ii
Just (1,2,3)


>>> iI f x y (iI f x y z Ii) Ii
Just (1,2,(1,2,3))

-}
iI :: forall f as t. InfixF (App f) as t => as -> t
iI = iIwith (App :: App f)

data App (f :: * -> *) = App
instance (fabfa ~ (f (a -> b), f a),
          fb ~ f b,
          Applicative f) => ApplyAB (App f) fabfa fb where
  applyAB _ = uncurry (<*>)



{- | infixr version


Another way to write hBuild:

>>> iIwithR HConsF 'a' "b" () [(),()] HNil Ii
H['a',"b",(),[(),()]]

-}
iIwithR :: InfixFr f '[] t => f -> t
iIwithR f = iIwithR' f HNil


class InfixFr f as t where
    iIwithR' :: f -> HList as -> t 

instance (InfixFr f (a ': as) c) => InfixFr f as (a -> c) where
    iIwithR' f as a = iIwithR' f (HCons a as)

instance (aas ~ (a ': as), HRevAppR as '[] ~ sa, HRevApp as '[],
          HFoldr f a sa b)  => InfixFr f aas (Ii -> b) where
    iIwithR' f (HCons a as) Ii = hFoldr f a (hReverse as)

data HConsF = HConsF
instance (y ~ HList (x ': xs),
          xxs ~ (x, HList xs) ) => ApplyAB HConsF xxs y where
    applyAB _ = uncurry HCons