{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE ConstraintKinds #-}

module AttributeData where

import Control.Monad
import Data.Data
import Data.Foldable
import Data.Function
import Data.Int
import Data.IORef
import Data.Maybe
import Data.Some
import Data.Word
import qualified Data.Map.Strict as Map
import qualified Data.Vector as V
         ;import Data.Vector as V ((!),(//))
import Foreign.C.Types (CPtrdiff)
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable
import qualified Type.Reflection as R

import LambdaCube.GL      as LC
import LambdaCube.GL.Data -- (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer)
import LambdaCube.GL.Mesh as LC
import LambdaCube.GL.Type
import LambdaCube.IR      as LC
import LambdaCube.GL.Util
import LambdaCube.GL.Input.Type
import LambdaCube.GL.Input hiding (createObjectCommands)

import Control.Monad.State.Lazy

import MaskableStream


lookupAttrKeys :: forall attrkeys. Data attrkeys => (String -> Maybe (Some AttributeKey)) -> Maybe attrkeys
lookupAttrKeys lookupA = do
    let dt = dataTypeOf (error "dataTypeOf attrkeys" :: attrkeys)
    case dataTypeRep dt of
        AlgRep (c:_) -> do
            let fields = constrFields c
                mkb :: (MonadPlus m, Data k) => String -> m k
                mkb n = case lookupA n of
                            Just (This k@(AttributeKey tt _ _)) -> case tagTypable tt of
                                Witness -> maybe mzero return $ cast k
                            _ -> mzero
            evalStateT (do { n:ns <- get ; put ns ; mkb n } `fromConstrM` c)
                       fields
        _ -> Nothing


reflectDim :: Num a => R.SomeTypeRep -> Maybe a
reflectDim r = case () of
    () | r==R.someTypeRep (Proxy :: Proxy 1) -> Just 1
       | r==R.someTypeRep (Proxy :: Proxy 2) -> Just 2
       | r==R.someTypeRep (Proxy :: Proxy 3) -> Just 3
       | r==R.someTypeRep (Proxy :: Proxy 4) -> Just 4
       | otherwise -> Nothing

reflectPrim :: R.SomeTypeRep -> Maybe (Some GLPointerType)
reflectPrim r = case () of
    () | r==R.someTypeRep (Proxy :: Proxy Float)  -> Just (This GLPrimFloat)
       | r==R.someTypeRep (Proxy :: Proxy Int32)  -> Just (This GLPrimInt)
       | r==R.someTypeRep (Proxy :: Proxy Word32) -> Just (This GLPrimUInt)
       | otherwise -> Nothing


reflectVectorType :: Typeable a => proxy a -> Maybe (Some TypeTag)
reflectVectorType proxy = go (R.someTypeRep proxy)
 where
   go :: R.SomeTypeRep -> Maybe (Some TypeTag)
   go rep = case rep of
    R.SomeTypeRep r -> case R.splitApps r of

        (v,[c,a])   -> do
            cols <- reflectDim c
            This p <- reflectPrim a
            Just $ case p of
                GLPrimUInt  -> case cols of
                    1 -> This TypeWord
                    2 -> This TypeV2U
                    3 -> This TypeV3U
                    4 -> This TypeV4U
                GLPrimInt   -> case cols of
                    1 -> This TypeInt
                    2 -> This TypeV2I
                    3 -> This TypeV3I
                    4 -> This TypeV4I
                GLPrimFloat -> case cols of
                    1 -> This TypeFloat
                    2 -> This TypeV2F
                    3 -> This TypeV3F
                    4 -> This TypeV4F

        (m,[r,c,a]) -> do
            rows <- reflectDim r
            cols <- reflectDim c
            This p <- reflectPrim a
            case p of
                GLPrimFloat -> case cols of
                    2 -> case rows of
                        2 -> Just $ This TypeM22F
                        3 -> Just $ This TypeM23F
                        4 -> Just $ This TypeM24F
                        _ -> Nothing
                    3 -> case rows of
                        2 -> Just $ This TypeM32F
                        3 -> Just $ This TypeM33F
                        4 -> Just $ This TypeM34F
                        _ -> Nothing
                    4 -> case rows of
                        2 -> Just $ This TypeM42F
                        3 -> Just $ This TypeM43F
                        4 -> Just $ This TypeM44F
                        _ -> Nothing
                _ -> Nothing

        (p,[x])     -> go x

        _           -> Nothing

fieldParameters :: forall attrkeys proxy. Data attrkeys => proxy attrkeys -> (String -> String) -> [Parameter]
fieldParameters proxy toAttrName = do
    let dt = dataTypeOf (error "dataTypeOf attrkeys" :: attrkeys)
    case dataTypeRep dt of
        AlgRep (c:_) -> do
            let fields = constrFields c
                mkb :: (MonadPlus m, Data k) => p k -> String -> m InputType
                mkb pxy n = case reflectVectorType pxy of
                    Just (This tt) -> return $ unwitnessType tt
                    _              -> mzero
                go :: Data c => StateT ([String],[Parameter]) Maybe c
                go = do (n:ns,ps) <- get
                        fix $ \pxy -> do
                            t <- mkb pxy n
                            put (ns,Parameter (toAttrName n) t:ps)
                            return undefined
            case runStateT (go `fromConstrM` c) (fields,[]) of
                Just (x,(_,ps)) -> ps where _ = x :: attrkeys
                Nothing         -> []
        _ -> []