MangledRegistry.hs

-- This module is a convenience layer upon the Registry module which knows
-- nothing about GL/GLX/EGL/WGL-specific things.
module MangledRegistry (
  ToEnumType,
  parseRegistry,
  Registry(..),
  Type(..),
  Group(..),
  Enum'(..),
  R.TypeName(..),
  R.TypeSuffix(..),
  Command(..), commandName,
  SignatureElement(..),
  Modification(..),
  R.ModificationKind(..),
  R.ProfileName(..),
  Extension(..),
  ConditionalModification(..),
  InterfaceElement(..),
  GroupName(..),
  EnumName(..),
  EnumValue(..),
  CommandName(..),
  ExtensionName(..),
  API(..),
  Version(..),
  splitWords, joinWords
) where

import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Maybe as DM
import qualified Data.Set as S
import qualified Numeric as N

import qualified DeclarationParser as D
import qualified Registry as R

type ToEnumType = Maybe String -> Maybe String -> Maybe String -> Maybe R.TypeSuffix -> R.TypeName

parseRegistry :: ToEnumType -> String -> Either String Registry
parseRegistry toEnumType str = toRegistry toEnumType `fmap` R.parseRegistry str

data Registry = Registry {
  types :: M.Map R.TypeName Type,
  groups :: M.Map GroupName Group,
  enums :: M.Map EnumName [Enum'],
  commands :: M.Map CommandName Command,
  features :: M.Map (API, Version) [Modification],
  extensions :: [Extension]
  } deriving (Eq, Ord, Show)

toRegistry :: ToEnumType -> R.Registry -> Registry
toRegistry toEnumType r = Registry {
  types = fromList'
    [ (typeNameOf t, toType t)
    | R.TypesElement te <- rs
    , t <- R.unTypes te ],
  groups = fromList'
    [ (GroupName . R.unName . R.groupName $ g, toGroup g)
    | R.GroupsElement ge <- rs
    , g <- R.unGroups ge ],
  enums = M.fromListWith (++)
   [ (enumName en, [en])
   | R.EnumsElement ee <- rs
   , Left e <- R.enumsEnumOrUnuseds ee
   , let en = toEnum' (toEnumType (R.enumsNamespace ee) (R.enumsGroup ee) (R.enumsType ee)) e ],
  commands = fromList'
   [ (CommandName . R.protoName . R.commandProto $ c, toCommand c)
   | R.CommandsElement ce <- rs
   , c <- R.commandsCommands ce ],
  features = fromList'
    [ ((API (R.featureAPI f), read (R.featureNumber f)),
       map toModification (R.featureModifications f))
    | R.FeatureElement f <- rs ],
  extensions =
    [ toExtension x
    | R.ExtensionsElement ee <- R.unRegistry r
    , x <- R.unExtensions ee ]
  } where rs = R.unRegistry r

fromList' :: (Ord k, Show a) => [(k,a)] -> M.Map k a
fromList' =
  M.fromListWith (\n o -> error $ "clash for " ++ show n ++ " and " ++ show o)

typeNameOf :: R.Type -> R.TypeName
typeNameOf t = case (R.typeName1 t, R.typeName2 t) of
  (Nothing, Nothing) -> error ("missing type name in " ++ show t)
  (Just n1, Nothing) -> n1
  (Nothing, Just n2) -> n2
  (Just n1, Just n2) | n1 == n2 -> n1
                     | otherwise -> error ("conflicting type name in " ++ show t)

data Type = Type {
  typeAPI :: Maybe API,
  typeRequires :: Maybe R.TypeName
  } deriving (Eq, Ord, Show)

toType :: R.Type -> Type
toType t = Type {
  typeAPI = API `fmap` R.typeAPI t,
  typeRequires = R.TypeName `fmap` R.typeRequires t }

data Group = Group {
  groupEnums :: [EnumName]
  } deriving (Eq, Ord, Show)

toGroup :: R.Group -> Group
toGroup g = Group {
  groupEnums = map (EnumName . R.unName) (R.groupEnums g) }

-- NOTE: Due to an oversight in the OpenGL ES spec, an enum can have different
-- values for different APIs (happens only for GL_ACTIVE_PROGRAM_EXT).
data Enum' = Enum {
  enumValue :: EnumValue,
  enumAPI :: Maybe API,
  enumType :: R.TypeName,
  enumName :: EnumName
  } deriving (Eq, Ord, Show)

toEnum' :: (Maybe R.TypeSuffix -> R.TypeName) -> R.Enum' -> Enum'
toEnum' toTypeName e = Enum {
  enumValue = EnumValue (R.enumValue e),
  enumAPI = API `fmap` R.enumAPI e,
  enumType = toTypeName (R.enumType e),
  enumName = EnumName (R.enumName e) }

splitChar :: Char
splitChar = '_'

splitWords :: String -> [String]
splitWords = splitBy (== splitChar)

splitBy :: (a -> Bool) -> [a] -> [[a]]
splitBy _ [] = []
splitBy p xs = case break p xs of
                (ys, []  ) -> [ys]
                (ys, _:zs) -> ys : splitBy p zs

joinWords :: [String] -> String
joinWords = L.intercalate [splitChar]

data Command = Command {
  resultType :: SignatureElement,
  paramTypes :: [SignatureElement],
  referencedTypes :: S.Set R.TypeName,
  vecEquiv :: Maybe CommandName,
  alias :: Maybe CommandName
  } deriving (Eq, Ord, Show)

toCommand :: R.Command -> Command
toCommand c = Command {
  resultType = resTy,
  paramTypes = paramTys,
  referencedTypes =
    S.fromList $
    -- Make sure that we don't reference pointers to structs, they are mapped to
    -- 'Ptr a' etc., anyway (glCreateSyncFromCLeventARB is an exmaple for this).
    filter (not . ("struct " `L.isPrefixOf`) . R.unTypeName) $
    DM.catMaybes $
    map (R.protoPtype . R.paramProto) $
    (pr : ps),
  vecEquiv = (CommandName . R.unName) `fmap` R.commandVecEquiv c,
  alias = (CommandName . R.unName) `fmap` R.commandAlias c }
  where pr = R.Param { R.paramLen = Nothing, R.paramProto = R.commandProto c }
        ps = R.commandParams c
        varSupply = map (R.TypeName . showIntUsingDigits ['a' .. 'z']) [0 ..]
        (resTy:paramTys) = snd $ L.mapAccumL toSignatureElement varSupply (pr : ps)

showIntUsingDigits :: [Char] -> Int -> String
showIntUsingDigits ds x = N.showIntAtBase (length ds) (ds !!) x ""

commandName :: Command -> CommandName
commandName = CommandName . signatureElementName . resultType

data SignatureElement = SignatureElement {
  arrayLength :: Maybe String,
  belongsToGroup :: Maybe GroupName,
  baseType :: R.TypeName,
  numPointer :: Int,
  signatureElementName :: String
  } deriving (Eq, Ord)

instance Show SignatureElement where
  showsPrec d ct
    | numPointer ct == 0 = showString (R.unTypeName (baseType ct))
    | otherwise =
        showParen (d > 10) $
        showString "Ptr " . showsPrec 11 (ct{numPointer = numPointer ct - 1})

  showList = flip . foldr  $ \x -> shows x . showString " -> "

-- We want to get 'Ptr a' instead of 'Ptr ()', so we might have to rename.
toSignatureElement :: [R.TypeName] -> R.Param -> ([R.TypeName], SignatureElement)
toSignatureElement varSupply param =
  either error (\(b,n) ->
    renameIf (b == "()" && n > 0)
             varSupply
             (SignatureElement {
                arrayLength = R.paramLen param,
                belongsToGroup = GroupName `fmap` R.protoGroup proto,
                numPointer = n,
                baseType = R.TypeName b,
                signatureElementName = R.protoName proto})) $
  D.parse $
  L.intercalate " " $
  map ($ proto) [
    R.protoText1,
    maybe "" R.unTypeName . R.protoPtype,
    R.protoText2,
    R.protoName,
    R.protoText3 ]
  where proto = R.paramProto param

renameIf :: Bool -> [R.TypeName] -> SignatureElement -> ([R.TypeName], SignatureElement)
renameIf False varSupply ct = (varSupply, ct)
renameIf True  varSupply ct = (tail varSupply, ct{ baseType = head varSupply })

data Modification = Modification {
  modificationKind :: R.ModificationKind,
  modificationProfile :: Maybe R.ProfileName,
  modificationInterfaceElements :: [InterfaceElement]
  } deriving (Eq, Ord, Show)

toModification :: R.Modification -> Modification
toModification m = Modification {
  modificationKind = R.modificationModificationKind m,
  modificationProfile = R.modificationProfileName m,
  modificationInterfaceElements = map toInterfaceElement (R.modificationInterfaceElements m) }

data Extension = Extension {
  extensionName :: ExtensionName,
  extensionSupported :: Maybe [API],
  extensionsRequireRemove :: [ConditionalModification]
  } deriving (Eq, Ord, Show)

toExtension :: R.Extension -> Extension
toExtension e = Extension {
  extensionName = toExtensionName $ R.extensionName e,
  extensionSupported = supp `fmap` R.extensionSupported e,
  extensionsRequireRemove = map toConditionalModification (R.extensionsRequireRemove e) }
  where supp = map API . splitBy (== '|') . R.unStringGroup

data ConditionalModification = ConditionalModification {
  conditionalModificationAPI :: Maybe API,
  conditionalModificationModification :: Modification
  } deriving (Eq, Ord, Show)

toConditionalModification :: R.ConditionalModification -> ConditionalModification
toConditionalModification c = ConditionalModification {
  conditionalModificationAPI = API `fmap` R.conditionalModificationAPI c,
  conditionalModificationModification = toModification (R.conditionalModificationModification c) }

data InterfaceElement
  = TypeElement R.TypeName
  | EnumElement EnumName
  | CommandElement CommandName
  deriving (Eq, Ord, Show)

toInterfaceElement :: R.InterfaceElement -> InterfaceElement
toInterfaceElement i =
  (case R.interfaceElementKind i of
     R.InterfaceElementType -> TypeElement . R.TypeName
     R.InterfaceElementEnum -> EnumElement . EnumName
     R.InterfaceElementCommand -> CommandElement . CommandName)
  (R.unName (R.interfaceElementName i))

newtype GroupName = GroupName { unGroupName :: String } deriving (Eq, Ord, Show)

newtype EnumName = EnumName { unEnumName :: String } deriving (Eq, Ord, Show)

-- Conceptually EnumValue should be an Integer, but the registry cheats a bit:
--
--   * xsd:decimal doesn't allow hex notation, which is used everywhere.
--   * egl.xml uses expression strings like "((EGLint)-1)".
--   * glx.xml uses "&quot;GLX&quot;", totally abusing it.
newtype EnumValue = EnumValue { unEnumValue :: String } deriving (Eq, Ord, Show)

newtype CommandName = CommandName { unCommandName :: String } deriving (Eq, Ord, Show)

-- See https://www.opengl.org/registry/doc/rules.html#spec_naming
data ExtensionName = ExtensionName {
  extensionNameAPI :: String,
  extensionNameCategory :: String,
  extensionNameName :: String
  } deriving (Eq, Ord, Show)

toExtensionName :: R.Name -> ExtensionName
toExtensionName name = ExtensionName {
   extensionNameAPI = a,
   extensionNameCategory = c,
   extensionNameName = joinWords rest }
   where (a:c:rest) = splitWords (R.unName name)

newtype API = API { unAPI :: String } deriving (Eq, Ord, Show)

data Version = Version {
  major :: Int,
  minor :: Int
  } deriving (Eq, Ord)

instance Show Version where
  showsPrec _ v = shows (major v) . showChar '.' . shows (minor v)

instance Read Version where
  readsPrec _ s = [ (Version ma mi, r3)
                  | (ma, r1) <- N.readDec s
                  , ('.':r2) <- [r1]
                  , (mi, r3) <- N.readDec r2 ]