{-# LANGUAGE CPP #-}

module Data.NestTuple.TH where



import Language.Haskell.TH

import Language.Syntactic.TH



mkTupT :: [Type] -> Type
mkTupT :: [Type] -> Type
mkTupT [Type]
ts = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Int -> Type
TupleT ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts)) [Type]
ts

mkPairT :: Type -> Type -> Type
mkPairT :: Type -> Type -> Type
mkPairT Type
a Type
b = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Int -> Type
TupleT Int
2) [Type
a,Type
b]

mkTupE :: [Exp] -> Exp
#if __GLASGOW_HASKELL__ >= 810
mkTupE :: [Exp] -> Exp
mkTupE = [Maybe Exp] -> Exp
TupE ([Maybe Exp] -> Exp) -> ([Exp] -> [Maybe Exp]) -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Maybe Exp) -> [Exp] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Maybe Exp
forall a. a -> Maybe a
Just
#else
mkTupE = TupE
#endif

mkPairE :: Exp -> Exp -> Exp
mkPairE :: Exp -> Exp -> Exp
mkPairE Exp
a Exp
b = [Exp] -> Exp
mkTupE [Exp
a,Exp
b]

mkPairP :: Pat -> Pat -> Pat
mkPairP :: Pat -> Pat -> Pat
mkPairP Pat
a Pat
b = [Pat] -> Pat
TupP [Pat
a,Pat
b]

data Nest a
    = Leaf a
    | Pair (Nest a) (Nest a)
  deriving (Nest a -> Nest a -> Bool
(Nest a -> Nest a -> Bool)
-> (Nest a -> Nest a -> Bool) -> Eq (Nest a)
forall a. Eq a => Nest a -> Nest a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Nest a -> Nest a -> Bool
$c/= :: forall a. Eq a => Nest a -> Nest a -> Bool
== :: Nest a -> Nest a -> Bool
$c== :: forall a. Eq a => Nest a -> Nest a -> Bool
Eq, Int -> Nest a -> ShowS
[Nest a] -> ShowS
Nest a -> String
(Int -> Nest a -> ShowS)
-> (Nest a -> String) -> ([Nest a] -> ShowS) -> Show (Nest a)
forall a. Show a => Int -> Nest a -> ShowS
forall a. Show a => [Nest a] -> ShowS
forall a. Show a => Nest a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Nest a] -> ShowS
$cshowList :: forall a. Show a => [Nest a] -> ShowS
show :: Nest a -> String
$cshow :: forall a. Show a => Nest a -> String
showsPrec :: Int -> Nest a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Nest a -> ShowS
Show, a -> Nest b -> Nest a
(a -> b) -> Nest a -> Nest b
(forall a b. (a -> b) -> Nest a -> Nest b)
-> (forall a b. a -> Nest b -> Nest a) -> Functor Nest
forall a b. a -> Nest b -> Nest a
forall a b. (a -> b) -> Nest a -> Nest b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Nest b -> Nest a
$c<$ :: forall a b. a -> Nest b -> Nest a
fmap :: (a -> b) -> Nest a -> Nest b
$cfmap :: forall a b. (a -> b) -> Nest a -> Nest b
Functor)

foldNest :: (a -> b) -> (b -> b -> b) -> Nest a -> b
foldNest :: (a -> b) -> (b -> b -> b) -> Nest a -> b
foldNest a -> b
leaf b -> b -> b
pair = Nest a -> b
go
  where
    go :: Nest a -> b
go (Leaf a
a) = a -> b
leaf a
a
    go (Pair Nest a
a Nest a
b) = b -> b -> b
pair (Nest a -> b
go Nest a
a) (Nest a -> b
go Nest a
b)

toNest :: [a] -> Nest a
toNest :: [a] -> Nest a
toNest [a
a] = a -> Nest a
forall a. a -> Nest a
Leaf a
a
toNest [a]
as  = Nest a -> Nest a -> Nest a
forall a. Nest a -> Nest a -> Nest a
Pair ([a] -> Nest a
forall a. [a] -> Nest a
toNest [a]
bs) ([a] -> Nest a
forall a. [a] -> Nest a
toNest [a]
cs)
  where
    ([a]
bs,[a]
cs) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt (([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
as Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [a]
as



-- Make instances of the form
--
-- > instance Nestable (a,...,x)
-- >   where
-- >     type Nested (a,...,x) = (a ... x)  -- nested pairs
-- >     nest   (a,...,x) = (a ... x)
-- >     unnest (a ... x) = (a,...,x)
mkNestableInstances
    :: Int  -- ^ Max tuple width
    -> DecsQ
mkNestableInstances :: Int -> DecsQ
mkNestableInstances Int
n = [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> DecsQ) -> [Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$ (Int -> Dec) -> [Int] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Dec
nestableInstance [Int
2..Int
n]
  where
    nestableInstance :: Int -> Dec
nestableInstance Int
w = [Type] -> Type -> [Dec] -> Dec
instD
        []
        (Type -> Type -> Type
AppT (Name -> Type
ConT (String -> Name
mkName String
"Nestable")) Type
tupT)
        [ Name -> [Type] -> Type -> Dec
tySynInst (String -> Name
mkName String
"Nested") [Type
tupT] ((Name -> Type) -> (Type -> Type -> Type) -> Nest Name -> Type
forall a b. (a -> b) -> (b -> b -> b) -> Nest a -> b
foldNest Name -> Type
VarT Type -> Type -> Type
mkPairT (Nest Name -> Type) -> Nest Name -> Type
forall a b. (a -> b) -> a -> b
$ [Name] -> Nest Name
forall a. [a] -> Nest a
toNest [Name]
vars)
        , Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"nest")
            [ [Pat] -> Body -> [Dec] -> Clause
Clause
                [[Pat] -> Pat
TupP ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
vars)]
                (Exp -> Body
NormalB ((Name -> Exp) -> (Exp -> Exp -> Exp) -> Nest Name -> Exp
forall a b. (a -> b) -> (b -> b -> b) -> Nest a -> b
foldNest Name -> Exp
VarE Exp -> Exp -> Exp
mkPairE (Nest Name -> Exp) -> Nest Name -> Exp
forall a b. (a -> b) -> a -> b
$ [Name] -> Nest Name
forall a. [a] -> Nest a
toNest [Name]
vars))
                []
            ]
        , Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"unnest")
            [ [Pat] -> Body -> [Dec] -> Clause
Clause
                [(Name -> Pat) -> (Pat -> Pat -> Pat) -> Nest Name -> Pat
forall a b. (a -> b) -> (b -> b -> b) -> Nest a -> b
foldNest Name -> Pat
VarP Pat -> Pat -> Pat
mkPairP (Nest Name -> Pat) -> Nest Name -> Pat
forall a b. (a -> b) -> a -> b
$ [Name] -> Nest Name
forall a. [a] -> Nest a
toNest [Name]
vars]
                (Exp -> Body
NormalB ([Exp] -> Exp
mkTupE ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
vars)))
                []
            ]
        ]
      where
        vars :: [Name]
vars = Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
w [Name]
varSupply
        tupT :: Type
tupT = [Type] -> Type
mkTupT ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
vars