Merge pull request achirkin#31 from expipiplus1/unsafe

Implement simple dynamic loader

changelog.md

@@ -1,5 +1,11 @@
 # Change Log
 
+## [2.1.0.0] - 2018-04-22
+  - Expose dynamic loader from Graphics.Vulkan.Dymamic
+  - Turn on platform specific features by default
+  - Make all foreign imports unsafe
+  - Add option for enabling safe calls
+
 ## [2.0.0.1] - 2018-04-21
   - Improved documentation (links, tables, math)
   - Use cpphs for preprocessing

generate/default.nix

@@ -15,9 +15,9 @@ let
     overrides = self: super: {
       pandoc = pkgs.haskell.lib.appendPatches
                  super.pandoc_2_1_2
-                 [ ./pandoc-math.patch
-                   ./pandoc-haddock-math.patch
-                   ./pandoc-haddock-table.patch
+                 [ ./pandoc-patches/pandoc-math.patch
+                   ./pandoc-patches/pandoc-haddock-math.patch
+                   ./pandoc-patches/pandoc-haddock-table.patch
                  ];
     };
   };

generate/generate.cabal

@@ -19,8 +19,13 @@ executable generate
   other-modules:       Control.Monad.Fix.Extra
                      , Data.Closure
                      , Data.Functor.Extra
+                     , Data.List.Extra2
                      , Data.MultiMap.Extra
                      , Data.Text.Extra
+                     , Documentation
+                     , Documentation.All
+                     , Documentation.Haddock
+                     , Documentation.RunAsciiDoctor
                      , Parse.Bitmask
                      , Parse.Command
                      , Parse.Constant
@@ -67,6 +72,7 @@ executable generate
                      , Spec.Tag
                      , Spec.Type
                      , Spec.VendorID
+                     , System.ProgressBar
                      , Text.InterpolatedString.Perl6.Unindented
                      , Write.Alias
                      , Write.BaseType
@@ -79,6 +85,7 @@ executable generate
                      , Write.EnumExtension
                      , Write.Handle
                      , Write.HeaderVersion
+                     , Write.Loader
                      , Write.Module
                      , Write.Module.Aggregate
                      , Write.Partition
@@ -88,7 +95,6 @@ executable generate
                      , Write.Type.Enum
                      , Write.Type.FuncPointer
                      , Write.Util
-
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall
   build-depends:       base >= 4.8 && < 4.11
                      , control-bool >= 0.2.1

generate/src/Data/Text/Extra.hs

@@ -8,12 +8,15 @@ module Data.Text.Extra
   , tShow
   , pattern Cons
   , upperCaseFirst
+  , lowerCaseFirst
   , dropPrefix
+  , dropPrefix'
   , (<+>)
   , module Data.Text
   ) where
 
 import           Data.Char
+import           Data.Maybe
 import           Data.Semigroup
 import           Data.String    (IsString)
 import           Data.Text
@@ -31,6 +34,9 @@ tShow = pack . show
 upperCaseFirst :: Text -> Text
 upperCaseFirst = onFirst Data.Char.toUpper
 
+lowerCaseFirst :: Text -> Text
+lowerCaseFirst = onFirst Data.Char.toLower
+
 onFirst :: (Char -> Char) -> Text -> Text
 onFirst f = \case
   Cons c cs -> Cons (f c) cs
@@ -45,5 +51,8 @@ dropPrefix prefix s = if prefix `T.isPrefixOf` s
                         then Just (T.drop (T.length prefix) s)
                         else Nothing
 
+dropPrefix' :: Text -> Text -> Text
+dropPrefix' prefix s = fromMaybe s (dropPrefix prefix s)
+
 (<+>) :: (IsString a, Semigroup a) => a -> a -> a
 a <+> b = a <> " " <> b

generate/src/Spec/Savvy/Command.hs

@@ -1,33 +1,48 @@
-{-# LANGUAGE ApplicativeDo   #-}
-{-# LANGUAGE LambdaCase      #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ApplicativeDo     #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
 
 module Spec.Savvy.Command
   ( Command(..)
   , Parameter(..)
+  , CommandLevel(..)
   , specCommands
   , commandType
   , lowerArrayToPointer
   ) where
 
+import           Control.Arrow
+import           Control.Monad
 import           Data.Closure
 import           Data.Either.Validation
+import           Data.Foldable
+import qualified Data.Map               as Map
+import           Data.Maybe
 import qualified Data.MultiMap          as MultiMap
 import           Data.Text
 import           Data.Traversable
+
 import qualified Spec.Command           as P
 import           Spec.Savvy.Error
+import           Spec.Savvy.Extension
+import           Spec.Savvy.Feature     (Requirement (..))
+import           Spec.Savvy.Handle
 import           Spec.Savvy.Type
 import qualified Spec.Spec              as P
+import           Write.Element          (HaskellName (TermName))
 
 data Command = Command
-  { cName       :: Text
-  , cReturnType :: Type
-  , cParameters :: [Parameter]
-  , cComment    :: Maybe Text
-  , cAliases    :: [Text]
+  { cName         :: Text
+  , cReturnType   :: Type
+  , cParameters   :: [Parameter]
+  , cComment      :: Maybe Text
+  , cAliases      :: [Text]
     -- ^ The closure of aliases to this command, doesn't include aliases in
     -- extensions
+  , cCommandLevel :: Maybe CommandLevel
+  , cPlatform     :: Maybe Text
+    -- ^ The platform this command runs on if it is not universal
   }
   deriving (Show)
 
@@ -37,14 +52,30 @@ data Parameter = Parameter
   }
   deriving (Show)
 
-specCommands :: TypeParseContext -> P.Spec -> Validation [SpecError] [Command]
-specCommands pc P.Spec {..}
+-- | The "level" of a command, related to what it is dispatched from.
+--
+-- Some commands are part of no level such as vkCreateInstance
+data CommandLevel
+  = Instance
+  | PhysicalDevice
+  | Device
+  deriving (Show, Eq)
+
+specCommands
+  :: TypeParseContext
+  -> P.Spec
+  -> [Handle]
+  -> [Extension]
+  -> Validation [SpecError] [Command]
+specCommands pc P.Spec {..} handles extensions
   = let
       commandAliases :: [(Text, Text)]
       commandAliases =
         [ (caAlias, caName) | P.CommandAlias {..} <- sCommandAliases ]
       aliasMap :: MultiMap.MultiMap Text Text
       aliasMap = MultiMap.fromList commandAliases
+      commandLevel' :: [Parameter] -> Maybe CommandLevel
+      commandLevel' = commandLevel handles
     in
       for sCommands $ \P.Command {..} -> do
         ret <- eitherToValidation $ stringToTypeExpected pc cName cReturnType
@@ -54,6 +85,14 @@ specCommands pc P.Spec {..}
         pure
           $ let cAliases =
                   closeNonReflexive (`MultiMap.lookup` aliasMap) [cName]
+                cCommandLevel = commandLevel' ps
+                cPlatform     = listToMaybe
+                  [ p
+                  | e          <- extensions
+                  , TermName n <- rRequiredNames =<< extRequirements e
+                  , n == cName
+                  , Just p <- [extPlatform e]
+                  ]
             in  Command {cReturnType = ret, cParameters = ps, ..}
 
 commandType :: Command -> Type
@@ -65,3 +104,19 @@ lowerArrayToPointer :: Type -> Type
 lowerArrayToPointer = \case
     Array _ t -> Ptr t
     t         -> t
+
+commandLevel :: [Handle] -> [Parameter] -> Maybe CommandLevel
+commandLevel handles =
+  let handleMap :: Text -> Maybe Handle
+      handleMap = (`Map.lookup` Map.fromList ((hName &&& id) <$> handles))
+      handleLevel :: Text -> Maybe CommandLevel
+      handleLevel = \case
+        "VkInstance"       -> Just Instance
+        "VkPhysicalDevice" -> Just PhysicalDevice
+        "VkDevice"         -> Just Device
+        handleName                  -> do
+          h <- handleMap handleName
+          asum $ handleLevel <$> hParents h
+  in  \case
+        Parameter _ (TypeName n) : _ -> handleLevel n
+        _                            -> Nothing

generate/src/Spec/Savvy/Handle.hs

@@ -22,6 +22,7 @@ data Handle = Handle
   { hName    :: Text
   , hType    :: Type
   , hAliases :: [Text]
+  , hParents :: [Text]
   }
   deriving (Show)
 
@@ -54,6 +55,7 @@ specHandles preprocess pc P.Spec {..} =
           $   Handle htName
           <$> (stringToTypeExpected pc' htName =<< preprocess htType)
           <*> pure (getAliases htName)
+          <*> pure htParents
         | P.HandleType {..} <- parsedHandles
         ]
 

generate/src/Spec/Savvy/Spec.hs

@@ -89,7 +89,10 @@ spec s = do
            )
 
   (sCommands, sStructs) <-
-    validationToEither $ (,) <$> specCommands pc s <*> specStructs tc s
+    validationToEither
+    $   (,)
+    <$> specCommands pc s sHandles sExtensions
+    <*> specStructs tc s
 
   sAliases <- validationToEither
     $ specAliases s sCommands sEnums sHandles sStructs sConstants requirements

generate/src/Spec/Savvy/Type.hs

@@ -16,6 +16,8 @@ module Spec.Savvy.Type
   , stringToTypeExpected
   , specParserContext
   , typeDepends
+  , isPtrType
+  , isArrayType
   ) where
 
 import           Control.Applicative
@@ -221,3 +223,13 @@ typeDepends = \case
   TypeName "Integral a => a"    -> []
   TypeName t                    -> [WE.TypeName t]
   Proto t ps -> typeDepends t ++ [ p | (_, pt) <- ps, p <- typeDepends pt ]
+
+isPtrType :: Type -> Bool
+isPtrType = \case
+  Ptr _ -> True
+  _ -> False
+
+isArrayType :: Type -> Bool
+isArrayType = \case
+  Array _ _ -> True
+  _ -> False

generate/src/Write/Alias.hs

@@ -54,8 +54,8 @@ writeValueAlias getType alias@Alias{..} = eitherToValidation $ do
 |]
       weExtensions = es
       weName       = "Value Alias: " <> aName
-      weProvides   = [Term aName]
-      weDepends    = [TermName aAliasName] ++ typeDepends (getType target)
+      weProvides   = [Unguarded $ Term aName]
+      weDepends    = Unguarded <$> [TermName aAliasName] ++ typeDepends (getType target)
   pure WriteElement {..}
 
 writePatternAlias
@@ -73,8 +73,8 @@ writePatternAlias getType alias@Alias{..} = eitherToValidation $ do
 |]
       weExtensions = "PatternSynonyms" : es
       weName       = "Pattern Alias: " <> aName
-      weProvides   = [Pattern aName]
-      weDepends    = PatternName aAliasName : typeDepends (getType target)
+      weProvides   = [Unguarded $ Pattern aName]
+      weDepends    = Unguarded <$> PatternName aAliasName : typeDepends (getType target)
   pure WriteElement {..}
 
 writeTypeAlias
@@ -88,8 +88,8 @@ writeTypeAlias Alias{..} =
 |]
       weExtensions = []
       weName       = "Type Alias: " <> aName
-      weProvides   = [TypeAlias aName]
-      weDepends    = [WE.TypeName aAliasName]
+      weProvides   = [Unguarded $ TypeAlias aName]
+      weDepends    = [Unguarded $ WE.TypeName aAliasName]
   in WriteElement {..}
 
 writeStructPatternAlias :: Alias Struct -> Validation [SpecError] WriteElement
@@ -106,9 +106,9 @@ writeStructPatternAlias alias@Alias{..} = eitherToValidation $ do
 |]
       weExtensions = "PatternSynonyms" : es
       weName       = "Struct Pattern Alias: " <> aName
-      weProvides   = [Pattern aName]
+      weProvides   = [Unguarded $ Pattern aName]
       weDepends    = -- This is not correct if we have a struct alias of a struct alias
-                     [WE.TypeName aAliasName] ++
+                     Unguarded <$> [WE.TypeName aAliasName] ++
                        (typeDepends . smType =<< sMembers)
   pure WriteElement {..}
 

generate/src/Write/BaseType.hs

@@ -23,8 +23,8 @@ writeBaseType :: BaseType -> Either [SpecError] WriteElement
 writeBaseType bt@BaseType {..} = do
   (weDoc, weImports, weExtensions) <- hDoc bt
   let weName     = "BaseType: " <> btName
-      weProvides = [TypeAlias btName]
-      weDepends  = typeDepends btType
+      weProvides = [Unguarded $ TypeAlias btName]
+      weDepends  = Unguarded <$> typeDepends btType
   pure WriteElement {..}
 
 hDoc :: BaseType -> Either [SpecError] (DocMap -> Doc (), [Import], [Text])

generate/src/Write/Bespoke.hs

@@ -28,7 +28,7 @@ namedType =
       weImports = []
       weExtensions = ["PolyKinds", "TypeOperators"]
       weName = "NamedType"
-      weProvides = [ TypeAlias "(:::)" ]
+      weProvides = Unguarded <$> [ TypeAlias "(:::)" ]
       weDepends = []
   in WriteElement{..}
 
@@ -66,7 +66,8 @@ versions =
                   ]
       weExtensions = ["PatternSynonyms", "ViewPatterns"]
       weName = "Version Macros"
-      weProvides = [ Pattern "VK_MAKE_VERSION"
+      weProvides = Unguarded <$>
+                   [ Pattern "VK_MAKE_VERSION"
                    , Pattern "VK_API_VERSION_1_0"
                    , Pattern "VK_API_VERSION_1_1"
                    , Term "_VK_VERSION_MAJOR"
@@ -87,7 +88,7 @@ nullHandle =
       weImports = [Import "Foreign.Ptr" ["Ptr", "nullPtr"]]
       weExtensions = ["PatternSynonyms", "ViewPatterns"]
       weName = "Null handle"
-      weProvides = [Pattern "VK_NULL_HANDLE"]
+      weProvides = [Unguarded $ Pattern "VK_NULL_HANDLE"]
       weDepends = []
   in WriteElement{..}
 
@@ -112,7 +113,7 @@ voidDataWriteElement n =
       weImports = []
       weExtensions = []
       weName = n
-      weProvides = [WithoutConstructors (TypeName n)]
+      weProvides = [Unguarded $ WithoutConstructors (TypeName n)]
       weDepends = []
   in WriteElement{..}
 
@@ -163,7 +164,8 @@ newtypeOrTypeWriteElement decl n t is =
       weExtensions = []
       weName = t
       -- TODO: Tidy
-      weProvides = if decl == "newtype"
+      weProvides = Unguarded <$>
+                   if decl == "newtype"
                      then [WithConstructors (TypeName n)]
                      else [WithoutConstructors (TypeName n)]
       weDepends = []