{-# LANGUAGE TemplateHaskell #-}

module Graphics.HaGL.TH.HaGL (
    gen2DCoordDecls,
    gen3DCoordDecls
) where

import Language.Haskell.TH
import Data.List (delete)


choose :: Eq a => Int -> [a] -> [[a]]
choose :: forall a. Eq a => Int -> [a] -> [[a]]
choose Int
0 [a]
_ = [[]]
choose Int
n [a]
xs = do
    a
x <- [a]
xs
    [a]
ys <- forall a. Eq a => Int -> [a] -> [[a]]
choose (Int
nforall a. Num a => a -> a -> a
-Int
1) (forall a. Eq a => a -> [a] -> [a]
delete a
x [a]
xs)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ a
xforall a. a -> [a] -> [a]
:[a]
ys

coordCon :: [Char] -> [Char]
coordCon [Char]
"x" = [Char]
"CoordX"
coordCon [Char]
"y" = [Char]
"CoordY"
coordCon [Char]
"z" = [Char]
"CoordZ"
coordCon [Char]
"w" = [Char]
"CoordW"

-- e.g.: xy_ v = mkExpr GLGenExpr (OpCoordMulti (CoordX `CoordCons` (CoordY `CoordCons` CoordNil)) v)
gen2DCoordDecls :: Q [Dec]
gen2DCoordDecls :: Q [Dec]
gen2DCoordDecls = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Char]] -> Dec
gen forall a b. (a -> b) -> a -> b
$ forall a. Eq a => Int -> [a] -> [[a]]
choose Int
2 [[Char]
"x", [Char]
"y", [Char]
"z", [Char]
"w"] where
    gen :: [[Char]] -> Dec
gen coords :: [[Char]]
coords@[[Char]
x, [Char]
y] = 
        Name -> [Clause] -> Dec
FunD
            ([Char] -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]]
coords forall a. [a] -> [a] -> [a]
++ [Char]
"_")
            [[Pat] -> Body -> [Dec] -> Clause
Clause
                [Name -> Pat
VarP forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"v"]
                (Exp -> Body
NormalB
                (Exp -> Exp -> Exp
AppE
                    (Exp -> Exp -> Exp
AppE
                        (Name -> Exp
VarE forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"mkExpr")
                        (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"GLGenExpr"))
                    (Exp -> Exp -> Exp
AppE
                        (Exp -> Exp -> Exp
AppE
                            (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"OpCoordMulti")
                            (Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE
                                (forall a. a -> Maybe a
Just (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
coordCon [Char]
x))
                                (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"CoordCons")
                                (forall a. a -> Maybe a
Just
                                (Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE
                                    (forall a. a -> Maybe a
Just (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
coordCon [Char]
y))
                                    (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"CoordCons")
                                    (forall a. a -> Maybe a
Just (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"CoordNil"))))))
                        (Name -> Exp
VarE forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"v"))))
                []]

-- e.g.: xyz_ v = mkExpr GLGenExpr (OpCoordMulti (CoordX `CoordCons` (CoordY `CoordCons` (CoordZ `CoordCons` CoordNil))) v)
gen3DCoordDecls :: Q [Dec]
gen3DCoordDecls :: Q [Dec]
gen3DCoordDecls = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Char]] -> Dec
gen forall a b. (a -> b) -> a -> b
$ forall a. Eq a => Int -> [a] -> [[a]]
choose Int
3 [[Char]
"x", [Char]
"y", [Char]
"z", [Char]
"w"] where
    gen :: [[Char]] -> Dec
gen coords :: [[Char]]
coords@[[Char]
x, [Char]
y, [Char]
z] = 
        Name -> [Clause] -> Dec
FunD
            ([Char] -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]]
coords forall a. [a] -> [a] -> [a]
++ [Char]
"_")
            [[Pat] -> Body -> [Dec] -> Clause
Clause
                [Name -> Pat
VarP forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"v"]
                (Exp -> Body
NormalB
                (Exp -> Exp -> Exp
AppE
                    (Exp -> Exp -> Exp
AppE
                        (Name -> Exp
VarE forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"mkExpr")
                        (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"GLGenExpr"))
                    (Exp -> Exp -> Exp
AppE
                        (Exp -> Exp -> Exp
AppE
                            (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"OpCoordMulti")
                            (Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE
                                (forall a. a -> Maybe a
Just (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
coordCon [Char]
x))
                                (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"CoordCons")
                                (forall a. a -> Maybe a
Just
                                (Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE
                                    (forall a. a -> Maybe a
Just (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
coordCon [Char]
y))
                                    (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"CoordCons")
                                    (forall a. a -> Maybe a
Just
                                        (Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE
                                            (forall a. a -> Maybe a
Just (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
coordCon [Char]
z))
                                            (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"CoordCons")
                                            (forall a. a -> Maybe a
Just (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"CoordNil"))))))))
                        (Name -> Exp
VarE forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"v"))))
                []]