content: {-# OPTIONS_GHC -Wall #-}
  -----------------------------------------------------------------------------
  -- |
  -- Copyright   :  (C) 2014 Edward Kmett and Gabríel Arthúr Pétursson
  -- License     :  BSD-style (see the file LICENSE)
  -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
  -- Stability   :  experimental
  -- Portability :  portable
  --
  ----------------------------------------------------------------------------
  module Registry
    ( Registry(..)
    , Command(..)
    , Parameter(..)
    , Enumeratee(..)
    , Extension(..)
    , Feature(..)
    , Group(..)
    , Remove(..)
    , Require(..)
    , Type(..)
    , lookupCommand
    , lookupEnum
    , deshenaniganize
    ) where
  
  import Data.Functor
  import Prelude
  
  data Registry = Registry
    { registryCommands :: [Command]
    , registryEnums :: [Enumeratee]
    , registryExtensions :: [Extension]
    , registryFeatures :: [Feature]
    , registryGroups :: [Group]
    } deriving (Eq, Show)
  
  data Parameter = Parameter
    { parameterName :: String
    , parameterType :: Type
    , parameterGroup :: Maybe String
    , parameterLen :: Maybe String
    } deriving (Eq, Show)
  
  data Command = Command
    { commandName :: String
    , commandType :: Type
    , commandParameters :: [Parameter]
    , commandVectorEquivalent :: Maybe String
    , commandAlias :: Maybe String
    } deriving (Eq, Show)
  
  data Enumeratee = Enumeratee
    { enumName :: String
    , enumValue :: String
    } deriving (Eq, Show)
  
  data Extension = Extension
    { extensionName :: String
    , extensionPlatform :: String
    , extensionRequires :: [Require]
    } deriving (Eq, Show)
  
  data Feature = Feature
    { featureName :: String
    , featureRequires :: [Require]
    , featureRemoves :: [Remove]
    } deriving (Eq, Show)
  
  data Group = Group
    { groupName :: String
    , groupEnum :: [String]
    } deriving (Eq, Show)
  
  data Remove = Remove
    { removeProfile :: String
    , removeComment :: String
    , removeEnums :: [String]
    , removeCommands :: [String]
    } deriving (Eq, Show)
  
  data Require = Require
    { requireEnums :: [String]
    , requireCommands :: [String]
    , requireComment :: String
    , requireProfile :: String
    } deriving (Eq, Show)
  
  data Type = Type
    { typeName :: Maybe String
    , typePointer :: Int
    } deriving (Eq, Show)
  
  lookupCommand :: Registry -> String -> Command
  lookupCommand registry command =
    head . filter ((== command) . commandName) $ registryCommands registry
  
  lookupEnum :: Registry -> String -> Enumeratee
  lookupEnum registry enum =
    head . filter ((== enum) . enumName) $ registryEnums registry
  
  -- | Resolve shenanigans in the OpenGL Registry
  deshenaniganize :: Registry -> Registry
  deshenaniganize registry = registry
    { registryFeatures =
       cleanFeature "GL_VERSION_3_1" clean31require .
       cleanFeature "GL_VERSION_4_4" clean44require .
       cleanFeature "GL_VERSION_4_5" clean45require .
       cleanFeature "GL_ES_VERSION_3_2" cleanES32require <$> registryFeatures registry
    , registryCommands = cleanCommand <$> registryCommands registry
    , registryExtensions = cleanExtensions <$> registryExtensions registry
    }
  
  cleanCommand :: Command -> Command
  cleanCommand cmd = cmd { commandParameters = cleanParameter <$> commandParameters cmd }
  
  cleanExtensions :: Extension -> Extension
  cleanExtensions ext
    | extensionName ext == "GL_EXT_multisampled_compatibility" =
        ext { extensionName = "GL_EXT_multisample_compatibility" }
    | otherwise = ext
  
  cleanParameter :: Parameter -> Parameter
  cleanParameter param
    | parameterName param == "baseAndCount" = param { parameterType = (parameterType param) { typePointer = 1 }}
    | otherwise = param { parameterGroup = cleanParameterGroup <$> parameterGroup param }
  
  cleanParameterGroup :: String -> String
  cleanParameterGroup "PixelInternalFormat" = "InternalFormat"
  cleanParameterGroup "SGIXFfdMask" = "FfdMaskSGIX"
  cleanParameterGroup xs = xs
  
  cleanFeature :: String -> (Require -> Require) -> Feature -> Feature
  cleanFeature name f feature
    | featureName feature == name = feature { featureRequires = f <$> featureRequires feature }
    | otherwise = feature
  
  clean31require :: Require -> Require
  clean31require require = require
    { requireCommands = filter (`notElem` removed) $ requireCommands require
    , requireEnums = "GL_BLEND_COLOR" : requireEnums require
    } where
    removed =
      [ "glBindBufferBase"
      , "glBindBufferRange"
      , "glGetIntegeri_v"
      ]
  
  clean44require :: Require -> Require
  clean44require require = require
    { requireEnums = filter (`notElem` removed) $
      requireEnums require
    } where
    removed =
      [ "GL_MAP_READ_BIT"
      , "GL_MAP_WRITE_BIT"
      , "GL_STENCIL_INDEX"
      , "GL_STENCIL_INDEX8"
      , "GL_TRANSFORM_FEEDBACK_BUFFER"
      , "GL_UNSIGNED_INT_10F_11F_11F_REV"
      ]
  
  clean45require :: Require -> Require
  clean45require require = require
    { requireEnums = filter (`notElem` removed) $
      requireEnums require
    } where
    removed =
      [ "GL_BACK"
      , "GL_LOWER_LEFT"
      , "GL_NONE"
      , "GL_NO_ERROR"
      , "GL_TEXTURE_BINDING_1D"
      , "GL_TEXTURE_BINDING_1D_ARRAY"
      , "GL_TEXTURE_BINDING_2D"
      , "GL_TEXTURE_BINDING_2D_ARRAY"
      , "GL_TEXTURE_BINDING_2D_MULTISAMPLE"
      , "GL_TEXTURE_BINDING_2D_MULTISAMPLE_ARRAY"
      , "GL_TEXTURE_BINDING_3D"
      , "GL_TEXTURE_BINDING_BUFFER"
      , "GL_TEXTURE_BINDING_CUBE_MAP"
      , "GL_TEXTURE_BINDING_CUBE_MAP_ARRAY"
      , "GL_TEXTURE_BINDING_RECTANGLE"
      , "GL_UPPER_LEFT"
      ]
  
  cleanES32require :: Require -> Require
  cleanES32require require = require
    { requireEnums = filter (`notElem` removed) $
      requireEnums require
    } where
    removed =
      [ "GL_CCW"
      , "GL_CW"
      , "GL_EQUAL"
      , "GL_NO_ERROR"
      , "GL_STENCIL_INDEX"
      , "GL_STENCIL_INDEX8"
      , "GL_TRIANGLES"
      ]
  