gl-0.7.8.1: Generator.hs

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE PatternGuards #-}
-----------------------------------------------------------------------------
-- |
-- 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 Generator (generateSource) where

import Control.Arrow
import Control.Monad
import Control.Monad.Trans.State
import Data.Char
import qualified Data.Foldable as Foldable
import Data.Functor
import Data.List
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import Data.Set (Set)
import Text.Printf
import Module
import Registry
import Utils
import Prelude

data Entry
  = F String
  | E String
  deriving (Eq, Ord, Show)

type Signature = String
type Name = String
type ModuleName = String
type SectionName = String
type ExtensionName = String
type ExportItem = String

data Category = C SectionName (Set ExportItem)
  deriving (Eq, Ord, Show)

saneEnum :: Name -> Name
saneEnum = ("GL_"++) . intercalate "_" . tail . splitOn "_"

saneModule :: Name -> Name
saneModule "422Pixels" = "FourTwoTwoPixels"
saneModule x = x

sanePrefix :: Name -> Name
sanePrefix "3DFX" = "ThreeDFX"
sanePrefix x = x

wrap :: Int -> Maybe String -> String -> String
wrap 0 _ s = s
wrap c w'@(Just w) s
  | any isSpace s = wrap (c-1) w' $ printf "%s (%s)" w s
  | otherwise = wrap (c-1) w' $ printf "%s %s" w s
wrap _ Nothing s = s

link :: Map Name Category -> Name -> String
link cs n = case Map.lookup n cs of
  Just (C _ ss) -> case compare (Set.size ss) 1 of
    GT -> "'Graphics.GL.Internal.Shared." ++ n ++ "'"
    EQ -> "'" ++ Set.findMin ss ++ "." ++ n ++ "'"
    LT -> "@" ++ n ++ "@"
  _ -> "@" ++ n ++ "@"

commandDescription :: Map String [String] -> Map Name Category -> Command -> Set String -> String
commandDescription fm cs (Command cmdName _cmdType cmdParameters vecEquiv alias) man = concat $
  [ "-- | Usage: @" ++ unwords (("'" ++ cmdName ++ "'") : map parameterName cmdParameters) ++ "@\n" ] ++
  [ case Map.lookup grp fm of
      Just xs -> printf "--\n-- The parameter @%s@ is a @%s@, one of: %s.\n"
         (parameterName param) grp $ intercalate ", " (map (link cs) xs)
      Nothing -> printf "--\n-- The parameter @%s@ is a @%s@.\n" (parameterName param) grp
  | param <- cmdParameters, Just grp <- [parameterGroup param] 
  ] ++
  [ "--\n-- The length of @" ++ parameterName param ++ "@ should be " ++ describeLength x ++ ".\n"
  | param <- cmdParameters, Just x <- [parameterLen param]
  ] ++
  [ "--\n-- This command is an alias for " ++ link cs a ++ ".\n" | Just a <- [alias] ] ++
  [ "--\n-- The vector equivalent of this command is " ++ link cs v ++ ".\n" | Just v <- [vecEquiv] ] ++
  [ "--\n-- Manual page: <https://www.opengl.org/sdk/docs/man/html/" ++ cmdName ++ ".xhtml>\n" | Set.member cmdName man ]
  where
    describeLength x = "@" ++ x ++ "@"

commandSignature :: Maybe Name -> Command -> Signature
commandSignature monad command =
  intercalate " -> " $ parameterSignature (commandParameters command) ++ [returnSignature $ commandType command]
  where
    parameterSignature :: [Parameter] -> [String]
    parameterSignature = map (typeSignature . parameterType)

    returnSignature :: Type -> String
    returnSignature t = wrap 1 monad . wrap (typePointer t) (Just "Ptr") $
      case typeName t of
        Nothing -> "()"
        Just "GLvoid" -> "()"
        Just x -> x

    typeSignature :: Type -> String
    typeSignature t = wrap (typePointer t) (Just "Ptr") $
      case typeName t of
        Nothing -> "()"
        Just "GLvoid" -> "()"
        Just "struct _cl_context" -> "()"
        Just "struct _cl_event" -> "()"
        Just x -> x

commonName :: Signature -> Name
commonName
  = concat
  . splitOn "GL"
  . concatMap (filter isAlphaNum . replace "()" "V")
  . splitOn " -> "
  . ioish

dynamicName :: Signature -> Name
dynamicName xs = "dyn" ++ commonName xs

invokerName :: Signature -> Name
invokerName xs = "ffi" ++ commonName xs

extensionModuleName :: ExtensionName -> ModuleName
extensionModuleName name =
  printf "Graphics.GL.Ext.%s.%s"
    (sanePrefix prefix) (saneModule $ camelCase (intercalate "_" rest))
  where
    (_:prefix:rest) = splitOn "_" name

    camelCase :: String -> String
    camelCase str = concatMap (\(x:xs) -> toUpper x : xs) $ splitOn "_" str

profileModuleName :: String -> String -> (ModuleName, Maybe ModuleName)
profileModuleName feature profile =
  (printf "Graphics.GL.%s" *** liftM (printf "Graphics.GL.%s")) submodule
  where
    submodule = case (feature, profile) of
      ("GL_VERSION_1_0", _) -> ("Standard10", Nothing)
      ("GL_VERSION_1_1", _) -> ("Standard11", Nothing)
      ("GL_VERSION_1_2", _) -> ("Standard12", Nothing)
      ("GL_VERSION_1_3", _) -> ("Standard13", Nothing)
      ("GL_VERSION_1_4", _) -> ("Standard14", Nothing)
      ("GL_VERSION_1_5", _) -> ("Standard15", Nothing)
      ("GL_VERSION_2_0", _) -> ("Standard20", Nothing)
      ("GL_VERSION_2_1", _) -> ("Standard21", Nothing)
      ("GL_VERSION_3_0", _) -> ("Standard30", Nothing)
      ("GL_VERSION_3_1", _) -> ("Standard31", Nothing)

      ("GL_VERSION_3_2", "core") -> ("Core32", Just "Compatibility32")
      ("GL_VERSION_3_2", "compatibility") -> ("Compatibility32", Nothing)
      ("GL_VERSION_3_2", _) -> ("Core32", Nothing)

      ("GL_VERSION_3_3", "core") -> ("Core33", Just "Compatibility33")
      ("GL_VERSION_3_3", "compatibility") -> ("Compatibility33", Nothing)
      ("GL_VERSION_3_3", _) -> ("Core33", Nothing)

      ("GL_VERSION_4_0", "core") -> ("Core40", Just "Compatibility40")
      ("GL_VERSION_4_0", "compatibility") -> ("Compatibility40", Nothing)
      ("GL_VERSION_4_0", _) -> ("Core40", Nothing)

      ("GL_VERSION_4_1", "core") -> ("Core41", Just "Compatibility41")
      ("GL_VERSION_4_1", "compatibility") -> ("Compatibility41", Nothing)
      ("GL_VERSION_4_1", _) -> ("Core41", Nothing)

      ("GL_VERSION_4_2", "core") -> ("Core42", Just "Compatibility42")
      ("GL_VERSION_4_2", "compatibility") -> ("Compatibility42", Nothing)
      ("GL_VERSION_4_2", _) -> ("Core42", Nothing)

      ("GL_VERSION_4_3", "core") -> ("Core43", Just "Compatibility43")
      ("GL_VERSION_4_3", "compatibility") -> ("Compatibility43", Nothing)
      ("GL_VERSION_4_3", _) -> ("Core43", Nothing)

      ("GL_VERSION_4_4", "core") -> ("Core44", Just "Compatibility44")
      ("GL_VERSION_4_4", "compatibility") -> ("Compatibility44", Nothing)
      ("GL_VERSION_4_4", _) -> ("Core44", Nothing)

      ("GL_VERSION_4_5", "core") -> ("Core45", Just "Compatibility45")
      ("GL_VERSION_4_5", "compatibility") -> ("Compatibility45", Nothing)
      ("GL_VERSION_4_5", _) -> ("Core45", Nothing)

      ("GL_VERSION_ES_CM_1_0", "common") -> ("EmbeddedCommon11", Nothing)
      ("GL_VERSION_ES_CM_1_0", _) -> ("EmbeddedLite11", Nothing)

      ("GL_ES_VERSION_2_0", _) -> ("Embedded20", Nothing)
      ("GL_ES_VERSION_3_0", _) -> ("Embedded30", Nothing)
      ("GL_ES_VERSION_3_1", _) -> ("Embedded31", Nothing)

      a -> error $ show a

implicitPrelude :: String -> ([String], [Body])
implicitPrelude m = case m of
  "Graphics.GL.Compatibility32" -> mk [
      "Graphics.GL.Core32"
    ]
  "Graphics.GL.Compatibility33" -> mk [
      "Graphics.GL.Compatibility32"
    , "Graphics.GL.Core33"
    ]
  "Graphics.GL.Compatibility40" -> mk [
      "Graphics.GL.Compatibility33"
    , "Graphics.GL.Core40"
    ]
  "Graphics.GL.Compatibility41" -> mk [
      "Graphics.GL.Compatibility40"
    , "Graphics.GL.Core41"
    ]
  "Graphics.GL.Compatibility42" -> mk [
      "Graphics.GL.Compatibility41"
    , "Graphics.GL.Core42"
    ]
  "Graphics.GL.Compatibility43" -> mk [
      "Graphics.GL.Compatibility42"
    , "Graphics.GL.Core43"
    ]
  "Graphics.GL.Compatibility44" -> mk [
      "Graphics.GL.Compatibility43"
    , "Graphics.GL.Core44"
    ]
  "Graphics.GL.Compatibility45" -> mk [
      "Graphics.GL.Compatibility44"
    , "Graphics.GL.Core45"
    ]
  "Graphics.GL.Core33" -> mk [
      "Graphics.GL.Core32"
    ]
  "Graphics.GL.Core40" -> mk [
      "Graphics.GL.Core33"
    ]
  "Graphics.GL.Core41" -> mk [
      "Graphics.GL.Core40"
    ]
  "Graphics.GL.Core42" -> mk [
      "Graphics.GL.Core41"
    ]
  "Graphics.GL.Core43" -> mk [
      "Graphics.GL.Core42"
    ]
  "Graphics.GL.Core44" -> mk [
      "Graphics.GL.Core43"
    ]
  "Graphics.GL.Core45" -> mk [
      "Graphics.GL.Core44"
    ]
  "Graphics.GL.EmbeddedCommon11" -> mk [
      "Graphics.GL.EmbeddedLite11"
    ]
  "Graphics.GL.Embedded30" -> mk [
      "Graphics.GL.Embedded20"
    ]
  "Graphics.GL.Embedded31" -> mk [
      "Graphics.GL.Embedded30"
    ]
  "Graphics.GL.Standard11" -> mk [
      "Graphics.GL.Standard10"
    ]
  "Graphics.GL.Standard12" -> mk [
      "Graphics.GL.Standard11"
    ]
  "Graphics.GL.Standard13" -> mk [
      "Graphics.GL.Standard12"
    ]
  "Graphics.GL.Standard14" -> mk [
      "Graphics.GL.Standard13"
    ]
  "Graphics.GL.Standard15" -> mk [
      "Graphics.GL.Standard14"
    ]
  "Graphics.GL.Standard20" -> mk [
      "Graphics.GL.Standard15"
    ]
  "Graphics.GL.Standard21" -> mk [
      "Graphics.GL.Standard20"
    ]
  "Graphics.GL.Standard30" -> mk [
      "Graphics.GL.Standard21"
    ]
  "Graphics.GL.Standard31" -> mk [
      "Graphics.GL.Standard30"
    ]
  "Graphics.GL.Ext.ANDROID.ExtensionPackEs31a" -> mk [
      "Graphics.GL.Ext.KHR.Debug"
    , "Graphics.GL.Ext.KHR.TextureCompressionAstcLdr"
    , "Graphics.GL.Ext.KHR.BlendEquationAdvanced"
    , "Graphics.GL.Ext.OES.SampleShading"
    , "Graphics.GL.Ext.OES.SampleVariables"
    , "Graphics.GL.Ext.OES.ShaderImageAtomic"
    , "Graphics.GL.Ext.OES.ShaderMultisampleInterpolation"
    , "Graphics.GL.Ext.OES.TextureStencil8"
    , "Graphics.GL.Ext.OES.TextureStorageMultisample2dArray"
    , "Graphics.GL.Ext.EXT.CopyImage"
    , "Graphics.GL.Ext.EXT.DrawBuffersIndexed"
    , "Graphics.GL.Ext.EXT.GeometryShader"
    , "Graphics.GL.Ext.EXT.GpuShader5"
    , "Graphics.GL.Ext.EXT.PrimitiveBoundingBox"
    , "Graphics.GL.Ext.EXT.ShaderIoBlocks"
    , "Graphics.GL.Ext.EXT.TessellationShader"
    , "Graphics.GL.Ext.EXT.TextureBorderClamp"
    , "Graphics.GL.Ext.EXT.TextureBuffer"
    , "Graphics.GL.Ext.EXT.TextureCubeMapArray"
    , "Graphics.GL.Ext.EXT.TextureSRGBDecode"
    ]
  _ -> ([], [])
  where
    mk names = (map ("module "++) names, [Import names])

requires :: String -> Require -> State (Map Entry Category) ()
requires name req = do
  forM_ (requireEnums req) $ \e ->
    modify $ Map.adjust (\(C v m) -> C v $ Set.insert name m) (E $ saneEnum e)

  forM_ (requireCommands req) $ \f ->
    modify $ Map.adjust (\(C v m) -> C v $ Set.insert name m) (F f)

entries :: Registry -> State (Map Entry Category) ()
entries registry = do
  forM_ (registryCommands registry) $ \f ->
    modify $ Map.insert
      (F $ commandName f)
      (C (commandSignature (Just "m") f) Set.empty)

  forM_ (registryEnums registry) $ \e ->
    modify $ Map.insert
      (E . saneEnum $ enumName e)
      (C (enumValue e) Set.empty)

  forM_ (registryExtensions registry) $ \ext ->
    forM_ (extensionRequires ext) $ \req ->
      requires (extensionModuleName $ extensionName ext) req

  forM_ (registryFeatures registry) $ \fe -> do
    let feature = featureName fe

    forM_ (featureRequires fe) $ \req -> do
      let name = fst . profileModuleName feature $ requireProfile req
      requires name req

      when ("Graphics.GL.Standard" `isPrefixOf` name) $
        requires "Graphics.GL.Core32" req

    forM_ (featureRemoves fe) $ \rm -> do
      let profile = removeProfile rm
      let (name, removeName) = profileModuleName feature profile

      forM_ (removeEnums rm) $ \e -> do
        modify $ Map.adjust
          (\(C v m) -> C v $ Set.delete name m)
          (E $ saneEnum e)

        case removeName of
          Just name' -> modify $ Map.adjust
            (\(C v m) -> C v $ Set.insert name' m) (E $ saneEnum e)
          Nothing -> return ()

      forM_ (removeCommands rm) $ \f -> do
        modify $ Map.adjust
          (\(C v m) -> C v $ Set.delete name m)
          (F f)

        case removeName of
          Just name' -> modify $ Map.adjust
            (\(C v m) -> C v $ Set.insert name' m) (F f)
          Nothing -> return ()

modules :: Registry
        -> Map Entry Category
        -> State (Map String [(Bool, Entry, String)]) ()
modules registry entr = do
  forM_ (registryExtensions registry) $ \ext ->
    modify $ Map.insert (extensionModuleName $ extensionName ext) []

  forM_ profiles $ \profile ->
    modify $ Map.insert (printf "Graphics.GL.%s" profile) []

  forM_ (Map.toList entr) $ \(k, C v ms) ->
    forM_ (Set.toList ms) $ \m ->
      modify $ Map.alter (f (Set.size ms > 1, k, v)) m
  where
    f r Nothing = Just [r]
    f r (Just a) = Just $ a ++ [r]

    profiles = [
        "Compatibility32"
      , "Compatibility33"
      , "Compatibility40"
      , "Compatibility41"
      , "Compatibility42"
      , "Compatibility43"
      , "Compatibility44"
      , "Compatibility45"
      , "Core32"
      , "Core33"
      , "Core40"
      , "Core41"
      , "Core42"
      , "Core43"
      , "Core44"
      , "Core45"
      , "EmbeddedCommon11"
      , "EmbeddedLite11"
      , "Embedded20"
      , "Embedded30"
      , "Embedded31"
      , "Standard10"
      , "Standard11"
      , "Standard12"
      , "Standard13"
      , "Standard14"
      , "Standard15"
      , "Standard20"
      , "Standard21"
      , "Standard30"
      , "Standard31"
      ]

data FunMap = FunMap
  { funSignatures   :: Map Name Signature           -- signatures by method name
  , funDescriptions :: Map Name String              -- descriptions by method name
  , funExtensions   :: Map ModuleName ExtensionName -- module name to extension name
  } deriving (Eq, Show)

ioish :: Signature -> Signature
ioish = replace "m (" "IO (" . replace "m GL" "IO GL"

funMap :: Registry -> Map Name Category -> [(Bool, Entry, String)] -> [String] -> FunMap
funMap registry cs es man = FunMap
  (Map.fromList [ (n, s) | (_, F n, s) <- es ])
  (Map.fromList [ (commandName cmd, commandDescription rgs cs cmd manset) | cmd <- registryCommands registry ])
  (Map.fromList $ map ((extensionModuleName&&&id).extensionName) $ registryExtensions registry)
  where rgs = Map.fromList [ (n, s) | Group n s <- registryGroups registry ]
        manset = Set.fromList man

funBody :: FunMap -> Name -> Signature -> [Body]
funBody fm n v =
  [ Code $ funDescriptions fm Map.! n
  , Function n ("MonadIO m => " ++ v) $ strip $ printf "= %s %s" (invokerName v) np
  , Function np ("FunPtr (" ++ v' ++ ")") $ strip $ printf "= unsafePerformIO (getProcAddress %s)" (show n)
  , Code $ printf "{-# NOINLINE %s #-}" np
  ] where
  np = n ++ "FunPtr"
  v' = ioish v

mkFFI :: FunMap -> Module
mkFFI fm = Module "Graphics.GL.Internal.FFI" export body where
  export = [ Section "Invokers" (nub $ invokerName <$> Foldable.toList (funSignatures fm)) ]
  body = Import
    [ "Control.Monad.IO.Class"
    , "Foreign.C.Types"
    , "Foreign.Ptr"
    , "Graphics.GL.Types"
    , "Numeric.Fixed"
    , "Numeric.Half"
    ] : nub (Foldable.concatMap invokers $ funSignatures fm)

invokers :: Signature -> [Body]
invokers v =
  [ Code $ printf "foreign import CALLCONV \"dynamic\" %s :: FunPtr (%s) -> %s" nd v' v'
  , Function ni (printf "MonadIO m => FunPtr (%s) -> %s" v' v) $
      printf "fp %s = liftIO (%s fp %s)" params nd params
  ] where
  parts = splitOn " -> " v
  numArgs = subtract 2 $ length parts
  params = unwords $ map (\x -> "v" ++ show x) [0..numArgs]
  v' = ioish v
  nd = dynamicName v
  ni = invokerName v

mkShared :: FunMap -> [(Bool, Entry, String)] -> Module
mkShared fm entr = Module "Graphics.GL.Internal.Shared" [] body
  where
    imp =
      [ Import
        [ "Control.Monad.IO.Class"
        , "Foreign.Ptr"
        , "Graphics.GL.Types"
        , "Graphics.GL.Internal.FFI"
        , "Graphics.GL.Internal.Proc"
        , "System.IO.Unsafe"
        ]
      ]

    body = imp ++ concatMap bodyF (nub entr)
    bodyF (False, _, _) = []
    bodyF (_, E n, v) = [Pattern n Nothing ("= " ++ v)]
    bodyF (_, F n, v) = funBody fm n v

mkModule :: FunMap -> Map String String -> String -> [(Bool, Entry, String)] -> Module
mkModule fm re m entr = Module m export body
  where
    entryName (E n) = "pattern " ++ n
    entryName (F n) = n

    (ie, ib) = implicitPrelude m
    hasUnsharedFunctions = any (\(s, e, _) -> not s && case e of F _ -> True; _ -> False) entr
    hasExt = Map.member m (funExtensions fm)

    export = case Map.lookup m (funExtensions fm) of
      Just en ->
        [ Section "Extension Support"
          [ "gl_" ++ (intercalate "_" . tail $ splitOn "_" en)
          ]
        , Section en $ ie ++ map (\(_, e, _) -> entryName e) entr
        ]
      Nothing ->
        [ Section m $ ie ++ map (\(_, e, _) -> entryName e) entr
        ]

    needsTypes (True, _, _) = False
    needsTypes (_ , E _, _) = False
    needsTypes (_ , F _, t) = "GL" `isInfixOf` t

    body =
      [ Import $ sort $ concat
        [ [ "Graphics.GL.Internal.Shared" | any (\(s, _, _) -> s) entr ]
        , [ "Graphics.GL.Internal.Proc"   | hasExt || hasUnsharedFunctions ]
        , [ "Graphics.GL.Types"           | any needsTypes entr ]
        , [ "Data.Set"                        | hasExt ]
        , guard hasUnsharedFunctions >>
          [ "Control.Monad.IO.Class"
          , "Foreign.Ptr"
          , "Graphics.GL.Internal.FFI"
          , "System.IO.Unsafe"
          ]
        ]
      ] ++
      ib ++
      extCheck ++
      concatMap bodyF entr

    tryLink en = case Map.lookup en re of
      Just uri -> "<" ++ uri ++ " " ++ en ++ ">"
      Nothing -> en

    extCheck = case Map.lookup m (funExtensions fm) of
      Just en 
        | parts@(_:_) <- tail (splitOn "_" en) ->
          [ Code $ "-- | Checks that the " ++ tryLink en ++ " extension is available."
          , Function ("gl_" ++ intercalate "_" parts) "Bool"
            (printf "= member %s extensions\n{-# NOINLINE %s #-}"
              (show en)
              ("gl_" ++ intercalate "_" parts))
          ]
        | otherwise -> error $ "malformed extension: " ++ en
      Nothing -> []

    bodyF (True, _, _) = []
    bodyF (_, E n, v) = [Pattern n Nothing ("= " ++ v)]
    bodyF (_, F n, v) = funBody fm n v

mkExtensionGather :: FunMap -> [Module]
mkExtensionGather fm = flip map extensionGroups $
  \x -> Module (printf "Graphics.GL.Ext.%s" $ sanePrefix x)
    [Section (printf "%s Extensions" x) $ map ("module "++) $ extInGroup x]
    [Import $ extInGroup x]
  where
  extInGroup grp
    = map fst
    . sort
    . filter (\x -> grp == (head . tail . splitOn "_" $ snd x))
    . Map.toList
    $ funExtensions fm

  extensionGroups
    = sort
    . nub
    . map (head . tail . splitOn "_" . snd)
    . Map.toList
    $ funExtensions fm

mkExtensionGroupGather :: [Module] -> Module
mkExtensionGroupGather ms = Module "Graphics.GL.Ext"
  [Section "Extensions" $ map (("module "++) . moduleName) ms]
  [Import $ map moduleName ms]

generateSource :: FilePath -> Registry -> [String] -> [(String, String)] -> IO ()
generateSource fp registry man extensions = do
  let s = execState (entries registry) Map.empty
  let m = execState (modules registry s) Map.empty
  let re = Map.fromList extensions
  let fm' = Foldable.concat m
  let s' = Map.fromList $ first entryName <$> Map.toList s
  let fm = funMap registry s' fm' man
  saveModule fp $ mkFFI fm
  saveModule fp $ mkShared fm fm'
  forM_ (Map.toList m) $ \(k,v) -> saveModule fp $ mkModule fm re k v
  let exts = mkExtensionGather fm
  forM_ exts $ saveModule fp
  saveModule fp $ mkExtensionGroupGather exts
  where
    entryName :: Entry -> String
    entryName (F s) = s
    entryName (E s) = s