haskell-gi 0.11 → 0.12
raw patch · 30 files changed
+1636/−1248 lines, 30 filesdep ~haskell-gi-base
Dependency ranges changed: haskell-gi-base
Files
- haskell-gi.cabal +3/−2
- src/GI/API.hs +4/−4
- src/GI/Attributes.hs +12/−49
- src/GI/Cabal.hs +35/−36
- src/GI/Callable.hs +140/−139
- src/GI/Code.hs +608/−119
- src/GI/CodeGen.hs +211/−244
- src/GI/Config.hs +2/−1
- src/GI/Constant.hs +67/−43
- src/GI/Conversions.hs +80/−79
- src/GI/GIR/BasicTypes.hs +1/−1
- src/GI/GIR/Deprecation.hs +6/−5
- src/GI/GIR/Documentation.hs +20/−0
- src/GI/GIR/Function.hs +1/−2
- src/GI/GIR/Method.hs +1/−2
- src/GI/GIR/Object.hs +3/−0
- src/GI/GIR/Parser.hs +13/−4
- src/GI/GIR/Struct.hs +4/−1
- src/GI/Inheritance.hs +4/−3
- src/GI/OverloadedSignals.hs +42/−85
- src/GI/Overrides.hs +11/−29
- src/GI/ProjectInfo.hs +6/−5
- src/GI/Properties.hs +83/−76
- src/GI/Signal.hs +112/−99
- src/GI/Struct.hs +21/−21
- src/GI/SymbolNaming.hs +28/−40
- src/GI/Transfer.hs +33/−33
- src/GI/Type.hs +1/−1
- src/GI/Util.hs +33/−45
- src/haskell-gi.hs +51/−80
haskell-gi.cabal view
@@ -1,5 +1,5 @@ name: haskell-gi-version: 0.11+version: 0.12 synopsis: Generate Haskell bindings for GObject Introspection capable libraries description: Generate Haskell bindings for GObject Introspection capable libraries. This includes most notably Gtk+, but many other libraries in the GObject ecosystem provide introspection data too.@@ -36,7 +36,7 @@ bytestring, xdg-basedir, xml-conduit >= 1.3.0,- haskell-gi-base == 0.10.*,+ haskell-gi-base == 0.12.*, text >= 1.0, free @@ -49,6 +49,7 @@ GI.GIR.Callback, GI.GIR.Constant, GI.GIR.Deprecation,+ GI.GIR.Documentation, GI.GIR.Enum, GI.GIR.Field, GI.GIR.Flags,
src/GI/API.hs view
@@ -309,7 +309,7 @@ prereqs <- case ifTypeInit iface of Nothing -> return [] Just ti -> do- gtype <- girLoadGType (T.pack ns) ti+ gtype <- girLoadGType ns ti prereqGTypes <- gtypeInterfaceListPrereqs gtype forM prereqGTypes $ \p -> do case M.lookup p csymbolMap of@@ -340,7 +340,7 @@ isBoxed <- case structTypeInit s of Nothing -> return False Just ti -> do- gtype <- girLoadGType (T.pack ns) ti+ gtype <- girLoadGType ns ti return (gtypeIsBoxed gtype) return (s {structIsBoxed = isBoxed}) @@ -348,7 +348,7 @@ -- by using libgirepository than reading the GIR file directly. fixupStructSizeAndOffsets :: Name -> Struct -> IO Struct fixupStructSizeAndOffsets (Name ns n) s = do- (size, offsetMap) <- girStructSizeAndOffsets (T.pack ns) (T.pack n)+ (size, offsetMap) <- girStructSizeAndOffsets ns n return (s { structSize = size , structFields = map (fixupField offsetMap) (structFields s)}) @@ -362,7 +362,7 @@ -- | Like 'fixupStructSizeAndOffset' above. fixupUnionSizeAndOffsets :: Name -> Union -> IO Union fixupUnionSizeAndOffsets (Name ns n) u = do- (size, offsetMap) <- girUnionSizeAndOffsets (T.pack ns) (T.pack n)+ (size, offsetMap) <- girUnionSizeAndOffsets ns n return (u { unionSize = size , unionFields = map (fixupField offsetMap) (unionFields u)})
src/GI/Attributes.hs view
@@ -1,22 +1,18 @@ module GI.Attributes- ( genAttributes- , genAllAttributes+ ( genAllAttributes ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif-import Control.Monad (forM_, when)-import Control.Monad.Writer (tell)+import Control.Monad (forM_) import qualified Data.Set as S-import qualified Data.Text as T import Data.Text (Text) import GI.API import GI.Code import GI.SymbolNaming-import GI.Properties-import GI.CodeGen (genPrelude)+import GI.Util (lcFirst) -- A list of distinct property names for all GObjects appearing in the -- given list of APIs.@@ -38,20 +34,17 @@ genPropertyAttr :: Text -> CodeGen () genPropertyAttr pName = group $ do- line $ "-- Property \"" ++ T.unpack pName ++ "\""- let name = (hyphensToCamelCase . T.unpack) pName- line $ "_" ++ lcFirst name ++ " :: Proxy \"" ++ T.unpack pName ++ "\""- line $ "_" ++ lcFirst name ++ " = Proxy"+ line $ "-- Property \"" <> pName <> "\""+ let name = hyphensToCamelCase pName+ line $ "_" <> lcFirst name <> " :: Proxy \"" <> pName <> "\""+ line $ "_" <> lcFirst name <> " = Proxy"+ exportToplevel ("_" <> lcFirst name) -genAllAttributes :: [(Name, API)] -> String -> CodeGen ()-genAllAttributes allAPIs modulePrefix = do- line "-- Generated code."- blank- line "{-# LANGUAGE DataKinds #-}"- blank+genAllAttributes :: [(Name, API)] -> CodeGen ()+genAllAttributes allAPIs = do+ setLanguagePragmas ["DataKinds"]+ setModuleFlags [ImplicitPrelude, NoTypesImport, NoCallbacksImport] - line $ "module " ++ modulePrefix ++ "Properties where"- blank line $ "import Data.Proxy (Proxy(..))" blank @@ -59,33 +52,3 @@ forM_ propNames $ \name -> do genPropertyAttr name blank--genProps :: (Name, API) -> CodeGen ()-genProps (n, APIObject o) = genObjectProperties n o-genProps (n, APIInterface i) = genInterfaceProperties n i-genProps _ = return ()--genAttributes :: String -> [(Name, API)] -> String -> CodeGen ()-genAttributes name apis modulePrefix = do- let mp = (modulePrefix ++)- nm = ucFirst name-- code <- recurse' $ forM_ apis genProps-- -- Providing orphan instances is the whole point of these modules,- -- tell GHC that this is fine.- line "{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-imports #-}"- blank-- genPrelude (nm ++ "Attributes") modulePrefix-- deps <- getDeps- forM_ (S.toList deps) $ \i -> when (i /= name) $ do- line $ "import qualified " ++ mp (ucFirst i) ++ " as " ++ ucFirst i- line $ "import qualified " ++ mp (ucFirst i) ++ "Attributes as "- ++ ucFirst i ++ "A"-- line $ "import " ++ modulePrefix ++ nm- blank-- tell code
src/GI/Cabal.hs view
@@ -9,9 +9,7 @@ #endif import Control.Monad (forM_) import Control.Monad.IO.Class (liftIO)-import Data.List (intercalate) import Data.Maybe (fromMaybe)-import Data.Monoid ((<>)) import Data.Version (Version(..)) import qualified Data.Map as M import qualified Data.Text as T@@ -24,14 +22,12 @@ import GI.Overrides (pkgConfigMap, cabalPkgVersion) import GI.PkgConfig (pkgConfigGetVersion) import GI.ProjectInfo (homepage, license, authors, maintainers)-import GI.Util (padTo)-import GI.SymbolNaming (ucFirst)+import GI.Util (padTo, tshow) import Paths_haskell_gi (version) cabalConfig :: Text-cabalConfig = T.unlines ["documentation: False",- "optimization: False"]+cabalConfig = T.unlines ["optimization: False"] setupHs :: Text setupHs = T.unlines ["#!/usr/bin/env runhaskell",@@ -83,13 +79,13 @@ -} giModuleVersion :: Int -> Int -> Text giModuleVersion major minor =- (T.pack . intercalate "." . map show) [haskellGIAPIVersion, major, minor,- haskellGIMinor]+ (T.intercalate "." . map tshow) [haskellGIAPIVersion, major, minor,+ haskellGIMinor] -- | Determine the next version for which the minor of the package has -- been bumped. giNextMinor :: Int -> Int -> Text-giNextMinor major minor = (T.pack . intercalate "." . map show)+giNextMinor major minor = (T.intercalate "." . map tshow) [haskellGIAPIVersion, major, minor+1] -- | Determine the pkg-config name and installed version (major.minor@@ -102,10 +98,10 @@ Just (n,v) -> case readMajorMinor v of Just (major, minor) -> return (n, major, minor)- Nothing -> notImplementedError . T.unpack $+ Nothing -> notImplementedError $ "Cannot parse version \"" <> v <> "\" for module " <> name- Nothing -> missingInfoError . T.unpack $+ Nothing -> missingInfoError $ "Could not determine the pkg-config name corresponding to \"" <> name <> "\".\n" <> "Try adding an override with the proper package name:\n" <> "pkg-config-name " <> name <> " [matching pkg-config name here]"@@ -121,8 +117,8 @@ -- | Try to generate the cabal project. In case of error return the -- corresponding error string.-genCabalProject :: GIRInfo -> [GIRInfo] -> String -> CodeGen (Maybe String)-genCabalProject gir deps modulePrefix =+genCabalProject :: GIRInfo -> [GIRInfo] -> [Text] -> CodeGen (Maybe Text)+genCabalProject gir deps exposedModules = handleCGExc (return . Just . describeCGError) $ do cfg <- config let pkMap = pkgConfigMap (overrides cfg)@@ -131,44 +127,47 @@ packages = girPCPackages gir line $ "-- Autogenerated, do not edit."- line $ padTo 20 "name:" <> "gi-" <> T.unpack (T.toLower name)+ line $ padTo 20 "name:" <> "gi-" <> T.toLower name (pcName, major, minor) <- tryPkgConfig name pkgVersion packages (verbose cfg) pkMap let cabalVersion = fromMaybe (giModuleVersion major minor) (cabalPkgVersion $ overrides cfg)- line $ padTo 20 "version:" ++ T.unpack cabalVersion- line $ padTo 20 "synopsis:" ++ T.unpack name- ++ " bindings"- line $ padTo 20 "description:" ++ "Bindings for " ++ T.unpack name- ++ ", autogenerated by haskell-gi."- line $ padTo 20 "homepage:" ++ homepage- line $ padTo 20 "license:" ++ license- line $ padTo 20 "license-file:" ++ "LICENSE"- line $ padTo 20 "author:" ++ authors- line $ padTo 20 "maintainer:" ++ maintainers- line $ padTo 20 "category:" ++ "Bindings"- line $ padTo 20 "build-type:" ++ "Simple"- line $ padTo 20 "cabal-version:" ++ ">=1.10"+ line $ padTo 20 "version:" <> cabalVersion+ line $ padTo 20 "synopsis:" <> name+ <> " bindings"+ line $ padTo 20 "description:" <> "Bindings for " <> name+ <> ", autogenerated by haskell-gi."+ line $ padTo 20 "homepage:" <> homepage+ line $ padTo 20 "license:" <> license+ line $ padTo 20 "license-file:" <> "LICENSE"+ line $ padTo 20 "author:" <> authors+ line $ padTo 20 "maintainer:" <> maintainers+ line $ padTo 20 "category:" <> "Bindings"+ line $ padTo 20 "build-type:" <> "Simple"+ line $ padTo 20 "cabal-version:" <> ">=1.10" blank line $ "library" indent $ do- line $ padTo 20 "default-language:" ++ "Haskell2010"- let base = modulePrefix ++ ucFirst (T.unpack name)- line $ padTo 20 "exposed-modules:" ++- intercalate ", " [base, base ++ "Attributes", base ++ "Signals"]- line $ padTo 20 "pkgconfig-depends:" ++ T.unpack pcName ++ " >= "- ++ show major ++ "." ++ show minor+ line $ padTo 20 "default-language:" <> "Haskell2010"+ line $ padTo 20 "default-extensions:" <> "OverloadedStrings, NegativeLiterals, ConstraintKinds, TypeFamilies, MultiParamTypeClasses, KindSignatures, FlexibleInstances, UndecidableInstances, DataKinds, FlexibleContexts"+ line $ padTo 20 "other-extensions:" <> "PatternSynonyms ScopedTypeVariables, ViewPatterns"+ line $ padTo 20 "ghc-options:" <> "-fno-warn-unused-imports -fno-warn-warnings-deprecations"+ line $ padTo 20 "exposed-modules:" <> head exposedModules+ forM_ (tail exposedModules) $ \mod ->+ line $ padTo 20 "" <> mod+ line $ padTo 20 "pkgconfig-depends:" <> pcName <> " >= "+ <> tshow major <> "." <> tshow minor line $ padTo 20 "build-depends: base >= 4.7 && <5," indent $ do line $ "haskell-gi-base >= "- ++ show haskellGIAPIVersion ++ "." ++ show haskellGIMinor- ++ " && < " ++ show (haskellGIAPIVersion + 1) ++ ","+ <> tshow haskellGIAPIVersion <> "." <> tshow haskellGIMinor+ <> " && < " <> tshow (haskellGIAPIVersion + 1) <> "," forM_ deps $ \dep -> do let depName = girNSName dep depVersion = girNSVersion dep depPackages = girPCPackages dep (_, depMajor, depMinor) <- tryPkgConfig depName depVersion depPackages (verbose cfg) pkMap- line . T.unpack $ "gi-" <> T.toLower depName <> " >= "+ line $ "gi-" <> T.toLower depName <> " >= " <> giModuleVersion depMajor depMinor <> " && < " <> giNextMinor depMajor depMinor
src/GI/Callable.hs view
@@ -15,7 +15,7 @@ #endif import Control.Monad (forM, forM_, when) import Data.Bool (bool)-import Data.List (intercalate, nub, (\\))+import Data.List (nub, (\\)) import Data.Maybe (isJust) import Data.Typeable (TypeRep, typeOf) import qualified Data.Map as Map@@ -46,22 +46,22 @@ let maybeHReturnType = if returnMayBeNull callable && not ignoreReturn then maybeT hReturnType else hReturnType- return $ case (outArgs, show maybeHReturnType) of+ return $ case (outArgs, tshow maybeHReturnType) of ([], _) -> maybeHReturnType (_, "()") -> "(,)" `con` hOutArgTypes _ -> "(,)" `con` (maybeHReturnType : hOutArgTypes) mkForeignImport :: Text -> Callable -> Bool -> CodeGen ()-mkForeignImport symbol callable throwsGError = foreignImport $ do+mkForeignImport symbol callable throwsGError = do line first indent $ do mapM_ (\a -> line =<< fArgStr a) (args callable) when throwsGError $- line $ padTo 40 "Ptr (Ptr GError) -> " ++ "-- error"+ line $ padTo 40 "Ptr (Ptr GError) -> " <> "-- error" line =<< last where- first = "foreign import ccall \"" ++ T.unpack symbol ++ "\" " ++- T.unpack symbol ++ " :: "+ first = "foreign import ccall \"" <> symbol <> "\" " <>+ symbol <> " :: " fArgStr arg = do ft <- foreignType $ argType arg weAlloc <- isJust <$> requiresAlloc (argType arg)@@ -69,10 +69,10 @@ ft else ptr ft- let start = show ft' ++ " -> "- return $ padTo 40 start ++ "-- " ++ T.unpack (argName arg)- ++ " : " ++ show (argType arg)- last = show <$> io <$> case returnType callable of+ let start = tshow ft' <> " -> "+ return $ padTo 40 start <> "-- " <> (argName arg)+ <> " : " <> tshow (argType arg)+ last = tshow <$> io <$> case returnType callable of TBasicType TVoid -> return $ typeOf () _ -> foreignType (returnType callable) @@ -94,24 +94,24 @@ nullable <- isNullable (argType arg) if nullable then return True- else badIntroError $ "argument \"" ++ T.unpack (argName arg)- ++ "\" is not of nullable type (" ++ show (argType arg)- ++ "), but it is marked as such."+ else badIntroError $ "argument \"" <> (argName arg)+ <> "\" is not of nullable type (" <> tshow (argType arg)+ <> "), but it is marked as such." else return False -- Given the list of arguments returns the list of constraints and the -- list of types in the signature.-inArgInterfaces :: [Arg] -> ExcCodeGen ([String], [String])+inArgInterfaces :: [Arg] -> ExcCodeGen ([Text], [Text]) inArgInterfaces inArgs = consAndTypes (['a'..'z'] \\ ['m']) inArgs where- consAndTypes :: [Char] -> [Arg] -> ExcCodeGen ([String], [String])+ consAndTypes :: [Char] -> [Arg] -> ExcCodeGen ([Text], [Text]) consAndTypes _ [] = return ([], []) consAndTypes letters (arg:args) = do (ls, t, cons) <- argumentType letters $ argType arg t' <- wrapMaybe arg >>= bool (return t)- (return $ "Maybe (" ++ t ++ ")")+ (return $ "Maybe (" <> t <> ")") (restCons, restTypes) <- consAndTypes ls args- return (cons ++ restCons, t' : restTypes)+ return (cons <> restCons, t' : restTypes) -- Given a callable, return a list of (array, length) pairs, where in -- each pair "length" is the argument holding the length of the@@ -132,7 +132,7 @@ -- arguments, including a possible length for the result of calling -- the function. arrayLengths :: Callable -> [Arg]-arrayLengths callable = map snd (arrayLengthsMap callable) +++arrayLengths callable = map snd (arrayLengthsMap callable) <> -- Often one of the arguments is just the length of -- the result. case returnType callable of@@ -176,39 +176,39 @@ wrapMaybe array >>= bool (do al <- computeArrayLength avar (argType array)- line $ "let " ++ lvar ++ " = " ++ al)+ line $ "let " <> lvar <> " = " <> al) (do- line $ "let " ++ lvar ++ " = case " ++ avar ++ " of"+ line $ "let " <> lvar <> " = case " <> avar <> " of" indent $ indent $ do line $ "Nothing -> 0"- let jarray = "j" ++ ucFirst avar+ let jarray = "j" <> ucFirst avar al <- computeArrayLength jarray (argType array)- line $ "Just " ++ jarray ++ " -> " ++ al)+ line $ "Just " <> jarray <> " -> " <> al) -- Check that the given array has a length equal to the given length -- variable. checkInArrayLength :: Name -> Arg -> Arg -> Arg -> ExcCodeGen () checkInArrayLength n array length previous = do name <- lowerName n- let funcName = namespace n ++ "." ++ name+ let funcName = namespace n <> "." <> name lvar = escapeReserved $ argName length avar = escapeReserved $ argName array- expectedLength = avar ++ "_expected_length_"+ expectedLength = avar <> "_expected_length_" pvar = escapeReserved $ argName previous wrapMaybe array >>= bool (do al <- computeArrayLength avar (argType array)- line $ "let " ++ expectedLength ++ " = " ++ al)+ line $ "let " <> expectedLength <> " = " <> al) (do- line $ "let " ++ expectedLength ++ " = case " ++ avar ++ " of"+ line $ "let " <> expectedLength <> " = case " <> avar <> " of" indent $ indent $ do line $ "Nothing -> 0"- let jarray = "j" ++ ucFirst avar+ let jarray = "j" <> ucFirst avar al <- computeArrayLength jarray (argType array)- line $ "Just " ++ jarray ++ " -> " ++ al)- line $ "when (" ++ expectedLength ++ " /= " ++ lvar ++ ") $"- indent $ line $ "error \"" ++ funcName ++ " : length of '" ++ avar ++- "' does not agree with that of '" ++ pvar ++ "'.\""+ line $ "Just " <> jarray <> " -> " <> al)+ line $ "when (" <> expectedLength <> " /= " <> lvar <> ") $"+ indent $ line $ "error \"" <> funcName <> " : length of '" <> avar <>+ "' does not agree with that of '" <> pvar <> "'.\"" -- Whether to skip the return value in the generated bindings. The -- C convention is that functions throwing an error and returning@@ -223,11 +223,11 @@ (skipReturn callable) || (throwsGError && returnType callable == TBasicType TBoolean) -freeInArgs' :: (Arg -> String -> String -> ExcCodeGen [String]) ->- Callable -> Map.Map String String -> ExcCodeGen [String]+freeInArgs' :: (Arg -> Text -> Text -> ExcCodeGen [Text]) ->+ Callable -> Map.Map Text Text -> ExcCodeGen [Text] freeInArgs' freeFn callable nameMap = concat <$> actions where- actions :: ExcCodeGen [[String]]+ actions :: ExcCodeGen [[Text]] actions = forM (args callable) $ \arg -> case Map.lookup (escapeReserved $ argName arg) nameMap of Just name -> freeFn arg name $@@ -237,7 +237,7 @@ TCArray False (-1) length _ -> escapeReserved $ argName $ (args callable)!!length _ -> undefined- Nothing -> badIntroError $ "freeInArgs: do not understand " ++ show arg+ Nothing -> badIntroError $ "freeInArgs: do not understand " <> tshow arg -- Return the list of actions freeing the memory associated with the -- callable variables. This is run if the call to the C function@@ -253,7 +253,7 @@ -- Marshall the haskell arguments into their corresponding C -- equivalents. omitted gives a list of DirectionIn arguments that -- should be ignored, as they will be dealt with separately.-prepareArgForCall :: [Arg] -> Arg -> ExcCodeGen String+prepareArgForCall :: [Arg] -> Arg -> ExcCodeGen Text prepareArgForCall omitted arg = do isCallback <- findAPI (argType arg) >>= \case Just (APICallback _) -> return True@@ -270,75 +270,75 @@ DirectionInout -> prepareInoutArg arg DirectionOut -> prepareOutArg arg -prepareInArg :: Arg -> ExcCodeGen String+prepareInArg :: Arg -> ExcCodeGen Text prepareInArg arg = do let name = escapeReserved $ argName arg wrapMaybe arg >>= bool (convert name $ hToF (argType arg) (transfer arg)) (do- let maybeName = "maybe" ++ ucFirst name- line $ maybeName ++ " <- case " ++ name ++ " of"+ let maybeName = "maybe" <> ucFirst name+ line $ maybeName <> " <- case " <> name <> " of" indent $ do line $ "Nothing -> return nullPtr"- let jName = "j" ++ ucFirst name- line $ "Just " ++ jName ++ " -> do"+ let jName = "j" <> ucFirst name+ line $ "Just " <> jName <> " -> do" indent $ do converted <- convert jName $ hToF (argType arg) (transfer arg)- line $ "return " ++ converted+ line $ "return " <> converted return maybeName) -- Callbacks are a fairly special case, we treat them separately.-prepareInCallback :: Arg -> ExcCodeGen String+prepareInCallback :: Arg -> ExcCodeGen Text prepareInCallback arg = do let name = escapeReserved $ argName arg- ptrName = "ptr" ++ name+ ptrName = "ptr" <> name scope = argScope arg (maker, wrapper) <- case argType arg of (TInterface ns n) -> do prefix <- qualify ns- return $ (prefix ++ "mk" ++ n,- prefix ++ lcFirst n ++ "Wrapper")- _ -> error $ "prepareInCallback : Not an interface! " ++ ppShow arg+ return $ (prefix <> "mk" <> n,+ prefix <> lcFirst n <> "Wrapper")+ _ -> terror $ "prepareInCallback : Not an interface! " <> T.pack (ppShow arg) when (scope == ScopeTypeAsync) $ do- ft <- show <$> foreignType (argType arg)- line $ ptrName ++ " <- callocMem :: IO (Ptr (" ++ ft ++ "))"+ ft <- tshow <$> foreignType (argType arg)+ line $ ptrName <> " <- callocMem :: IO (Ptr (" <> ft <> "))" wrapMaybe arg >>= bool (do let name' = prime name p = if (scope == ScopeTypeAsync)- then parenthesize $ "Just " ++ ptrName+ then parenthesize $ "Just " <> ptrName else "Nothing"- line $ name' ++ " <- " ++ maker ++ " "- ++ parenthesize (wrapper ++ " " ++ p ++ " " ++ name)+ line $ name' <> " <- " <> maker <> " "+ <> parenthesize (wrapper <> " " <> p <> " " <> name) when (scope == ScopeTypeAsync) $- line $ "poke " ++ ptrName ++ " " ++ name'+ line $ "poke " <> ptrName <> " " <> name' return name') (do- let maybeName = "maybe" ++ ucFirst name- line $ maybeName ++ " <- case " ++ name ++ " of"+ let maybeName = "maybe" <> ucFirst name+ line $ maybeName <> " <- case " <> name <> " of" indent $ do line $ "Nothing -> return (castPtrToFunPtr nullPtr)"- let jName = "j" ++ ucFirst name+ let jName = "j" <> ucFirst name jName' = prime jName- line $ "Just " ++ jName ++ " -> do"+ line $ "Just " <> jName <> " -> do" indent $ do let p = if (scope == ScopeTypeAsync)- then parenthesize $ "Just " ++ ptrName+ then parenthesize $ "Just " <> ptrName else "Nothing"- line $ jName' ++ " <- " ++ maker ++ " "- ++ parenthesize (wrapper ++ " "- ++ p ++ " " ++ jName)+ line $ jName' <> " <- " <> maker <> " "+ <> parenthesize (wrapper <> " "+ <> p <> " " <> jName) when (scope == ScopeTypeAsync) $- line $ "poke " ++ ptrName ++ " " ++ jName'- line $ "return " ++ jName'+ line $ "poke " <> ptrName <> " " <> jName'+ line $ "return " <> jName' return maybeName) -prepareInoutArg :: Arg -> ExcCodeGen String+prepareInoutArg :: Arg -> ExcCodeGen Text prepareInoutArg arg = do name' <- prepareInArg arg ft <- foreignType $ argType arg@@ -351,19 +351,19 @@ wrapMaybe arg >>= bool (do name'' <- genConversion (prime name') $- literal $ M $ allocator ++ " " ++ show n ++- " :: " ++ show (io ft)- line $ "memcpy " ++ name'' ++ " " ++ name' ++ " " ++ show n+ literal $ M $ allocator <> " " <> tshow n <>+ " :: " <> tshow (io ft)+ line $ "memcpy " <> name'' <> " " <> name' <> " " <> tshow n return name'') -- The semantics of this case are somewhat undefined. (notImplementedError "Nullable inout structs not supported") Nothing -> do name'' <- genConversion (prime name') $- literal $ M $ "allocMem :: " ++ show (io $ ptr ft)- line $ "poke " ++ name'' ++ " " ++ name'+ literal $ M $ "allocMem :: " <> tshow (io $ ptr ft)+ line $ "poke " <> name'' <> " " <> name' return name'' -prepareOutArg :: Arg -> CodeGen String+prepareOutArg :: Arg -> CodeGen Text prepareOutArg arg = do let name = escapeReserved $ argName arg ft <- foreignType $ argType arg@@ -373,32 +373,32 @@ let allocator = if isBoxed then "callocBoxedBytes" else "callocBytes"- genConversion name $ literal $ M $ allocator ++ " " ++ show n ++- " :: " ++ show (io ft)+ genConversion name $ literal $ M $ allocator <> " " <> tshow n <>+ " :: " <> tshow (io ft) Nothing -> genConversion name $- literal $ M $ "allocMem :: " ++ show (io $ ptr ft)+ literal $ M $ "allocMem :: " <> tshow (io $ ptr ft) -- Convert a non-zero terminated out array, stored in a variable -- named "aname", into the corresponding Haskell object.-convertOutCArray :: Callable -> Type -> String -> Map.Map String String ->- Transfer -> ExcCodeGen String+convertOutCArray :: Callable -> Type -> Text -> Map.Map Text Text ->+ Transfer -> ExcCodeGen Text convertOutCArray callable t@(TCArray False fixed length _) aname nameMap transfer = do if fixed > -1 then do- unpacked <- convert aname $ unpackCArray (show fixed) t transfer+ unpacked <- convert aname $ unpackCArray (tshow fixed) t transfer -- Free the memory associated with the array freeContainerType transfer t aname undefined return unpacked else do when (length == -1) $- badIntroError $ "Unknown length for \"" ++ aname ++ "\""+ badIntroError $ "Unknown length for \"" <> aname <> "\"" let lname = escapeReserved $ argName $ (args callable)!!length lname' <- case Map.lookup lname nameMap of Just n -> return n Nothing ->- badIntroError $ "Couldn't find out array length " +++ badIntroError $ "Couldn't find out array length " <> lname let lname'' = prime lname' unpacked <- convert aname $ unpackCArray lname'' t transfer@@ -408,10 +408,10 @@ -- Remove the warning, this should never be reached. convertOutCArray _ t _ _ _ =- error $ "convertOutCArray : unexpected " ++ show t+ terror $ "convertOutCArray : unexpected " <> tshow t -- Read the array lengths for out arguments.-readOutArrayLengths :: Callable -> Map.Map String String -> ExcCodeGen ()+readOutArrayLengths :: Callable -> Map.Map Text Text -> ExcCodeGen () readOutArrayLengths callable nameMap = do let lNames = nub $ map (escapeReserved . argName) $ filter ((/= DirectionIn) . direction) $@@ -420,7 +420,7 @@ lname' <- case Map.lookup lname nameMap of Just n -> return n Nothing ->- badIntroError $ "Couldn't find out array length " +++ badIntroError $ "Couldn't find out array length " <> lname genConversion lname' $ apply $ M "peek" @@ -433,13 +433,13 @@ Just a -> do managed <- isManaged a when managed $ wrapMaybe arg >>= bool- (line $ "mapM_ touchManagedPtr " ++ name)- (line $ "whenJust " ++ name ++ " (mapM_ touchManagedPtr)")+ (line $ "mapM_ touchManagedPtr " <> name)+ (line $ "whenJust " <> name <> " (mapM_ touchManagedPtr)") Nothing -> do managed <- isManaged (argType arg) when managed $ wrapMaybe arg >>= bool- (line $ "touchManagedPtr " ++ name)- (line $ "whenJust " ++ name ++ " touchManagedPtr")+ (line $ "touchManagedPtr " <> name)+ (line $ "whenJust " <> name <> " touchManagedPtr") -- Find the association between closure arguments and their -- corresponding callback.@@ -464,75 +464,75 @@ c -> case Map.lookup c m of Just _ -> notImplementedError $ "Closure for multiple callbacks unsupported"- ++ ppShow arg ++ "\n"- ++ ppShow callable+ <> T.pack (ppShow arg) <> "\n"+ <> T.pack (ppShow callable) Nothing -> go as $ Map.insert c arg m -- user_data style arguments.-prepareClosures :: Callable -> Map.Map String String -> ExcCodeGen ()+prepareClosures :: Callable -> Map.Map Text Text -> ExcCodeGen () prepareClosures callable nameMap = do m <- closureToCallbackMap callable let closures = filter (/= -1) . map argClosure $ args callable forM_ closures $ \closure -> case Map.lookup closure m of Nothing -> badIntroError $ "Closure not found! "- ++ ppShow callable- ++ "\n" ++ ppShow m- ++ "\n" ++ show closure+ <> T.pack (ppShow callable)+ <> "\n" <> T.pack (ppShow m)+ <> "\n" <> tshow closure Just cb -> do let closureName = escapeReserved $ argName $ (args callable)!!closure n = escapeReserved $ argName cb n' <- case Map.lookup n nameMap of Just n -> return n Nothing -> badIntroError $ "Cannot find closure name!! "- ++ ppShow callable ++ "\n"- ++ ppShow nameMap+ <> T.pack (ppShow callable) <> "\n"+ <> T.pack (ppShow nameMap) case argScope cb of ScopeTypeInvalid -> badIntroError $ "Invalid scope! "- ++ ppShow callable+ <> T.pack (ppShow callable) ScopeTypeNotified -> do- line $ "let " ++ closureName ++ " = castFunPtrToPtr " ++ n'+ line $ "let " <> closureName <> " = castFunPtrToPtr " <> n' case argDestroy cb of (-1) -> badIntroError $ "ScopeTypeNotified without destructor! "- ++ ppShow callable+ <> T.pack (ppShow callable) k -> let destroyName = escapeReserved . argName $ (args callable)!!k in- line $ "let " ++ destroyName ++ " = safeFreeFunPtrPtr"+ line $ "let " <> destroyName <> " = safeFreeFunPtrPtr" ScopeTypeAsync ->- line $ "let " ++ closureName ++ " = nullPtr"- ScopeTypeCall -> line $ "let " ++ closureName ++ " = nullPtr"+ line $ "let " <> closureName <> " = nullPtr"+ ScopeTypeCall -> line $ "let " <> closureName <> " = nullPtr" -freeCallCallbacks :: Callable -> Map.Map String String -> ExcCodeGen ()+freeCallCallbacks :: Callable -> Map.Map Text Text -> ExcCodeGen () freeCallCallbacks callable nameMap = forM_ (args callable) $ \arg -> do let name = escapeReserved $ argName arg name' <- case Map.lookup name nameMap of Just n -> return n- Nothing -> badIntroError $ "Could not find " ++ name- ++ " in " ++ ppShow callable ++ "\n"- ++ ppShow nameMap+ Nothing -> badIntroError $ "Could not find " <> name+ <> " in " <> T.pack (ppShow callable) <> "\n"+ <> T.pack (ppShow nameMap) when (argScope arg == ScopeTypeCall) $- line $ "safeFreeFunPtr $ castFunPtrToPtr " ++ name'+ line $ "safeFreeFunPtr $ castFunPtrToPtr " <> name' hSignature :: [Arg] -> TypeRep -> ExcCodeGen () hSignature hInArgs retType = do (argConstraints, types) <- inArgInterfaces hInArgs indent $ do- line $ "(" ++ intercalate ", " ("MonadIO m" : argConstraints) ++ ") =>"+ line $ "(" <> T.intercalate ", " ("MonadIO m" : argConstraints) <> ") =>" forM_ (zip types hInArgs) $ \(t, a) ->- line $ withComment (t ++ " ->") $ T.unpack (argName a)- line . show $ "m" `con` [retType]+ line $ withComment (t <> " ->") $ (argName a)+ line . tshow $ "m" `con` [retType] genCallable :: Name -> Text -> Callable -> Bool -> ExcCodeGen () genCallable n symbol callable throwsGError = do group $ do- line $ "-- Args : " ++ (show $ args callable)- line $ "-- Lengths : " ++ (show $ arrayLengths callable)- line $ "-- hInArgs : " ++ show hInArgs- line $ "-- returnType : " ++ (show $ returnType callable)- line $ "-- throws : " ++ (show throwsGError)- line $ "-- Skip return : " ++ (show $ skipReturn callable)+ line $ "-- Args : " <> (tshow $ args callable)+ line $ "-- Lengths : " <> (tshow $ arrayLengths callable)+ line $ "-- hInArgs : " <> tshow hInArgs+ line $ "-- returnType : " <> (tshow $ returnType callable)+ line $ "-- throws : " <> (tshow throwsGError)+ line $ "-- Skip return : " <> (tshow $ skipReturn callable) when (skipReturn callable && returnType callable /= TBasicType TBoolean) $ do line "-- XXX return value ignored, but it is not a boolean." line "-- This may be a memory leak?"@@ -546,7 +546,7 @@ -- and C array length arguments to Haskell code. closures = map (args callable!!) . filter (/= -1) . map argClosure $ inArgs destroyers = map (args callable!!) . filter (/= -1) . map argDestroy $ inArgs- omitted = arrayLengths callable ++ closures ++ destroyers+ omitted = arrayLengths callable <> closures <> destroyers hInArgs = filter (`notElem` omitted) inArgs outArgs = filter ((/= DirectionIn) . direction) $ args callable hOutArgs = filter (`notElem` (arrayLengths callable)) outArgs@@ -556,10 +556,11 @@ wrapper = group $ do let argName' = escapeReserved . argName name <- lowerName n+ exportMethod name name line $ deprecatedPragma name $ callableDeprecated callable- line $ name ++ " ::"+ line $ name <> " ::" hSignature hInArgs =<< hOutType callable hOutArgs ignoreReturn- line $ name ++ " " ++ intercalate " " (map argName' hInArgs) ++ " = liftIO $ do"+ line $ name <> " " <> T.intercalate " " (map argName' hInArgs) <> " = liftIO $ do" indent $ do readInArrayLengths n callable hInArgs inArgNames <- forM (args callable) $ \arg ->@@ -607,10 +608,10 @@ maybeCatchGErrors = if throwsGError then "propagateGError $ " else ""- line $ returnBind ++ maybeCatchGErrors- ++ T.unpack symbol ++ concatMap (" " ++) argNames+ line $ returnBind <> maybeCatchGErrors+ <> symbol <> (T.concat . map (" " <>)) argNames - convertResult :: Map.Map String String -> ExcCodeGen String+ convertResult :: Map.Map Text Text -> ExcCodeGen Text convertResult nameMap = if ignoreReturn || returnType callable == TBasicType TVoid then return (error "convertResult: unreachable code reached, bug!")@@ -620,13 +621,13 @@ line $ "maybeResult <- convertIfNonNull result $ \\result' -> do" indent $ do converted <- unwrappedConvertResult "result'"- line $ "return " ++ converted+ line $ "return " <> converted return "maybeResult" else do nullable <- isNullable (returnType callable) when nullable $- line $ "checkUnexpectedReturnNULL \"" ++ T.unpack symbol- ++ "\" result"+ line $ "checkUnexpectedReturnNULL \"" <> symbol+ <> "\" result" unwrappedConvertResult "result" where@@ -645,14 +646,14 @@ freeContainerType (returnTransfer callable) t rname undefined return result - convertOut :: Map.Map String String -> ExcCodeGen [String]+ convertOut :: Map.Map Text Text -> ExcCodeGen [Text] convertOut nameMap = do -- Convert out parameters and result forM hOutArgs $ \arg -> do let name = escapeReserved $ argName arg inName <- case Map.lookup name nameMap of Just name' -> return name'- Nothing -> badIntroError $ "Parameter " ++ name ++ " not found!"+ Nothing -> badIntroError $ "Parameter " <> name <> " not found!" case argType arg of -- Passed along as a raw pointer TCArray False (-1) (-1) _ -> genConversion inName $ apply $ M "peek"@@ -662,13 +663,13 @@ nameMap (transfer arg) wrapMaybe arg >>= bool (wrapArray aname')- (do line $ "maybe" ++ ucFirst aname'- ++ " <- convertIfNonNull " ++ aname'- ++ " $ \\" ++ prime aname' ++ " -> do"+ (do line $ "maybe" <> ucFirst aname'+ <> " <- convertIfNonNull " <> aname'+ <> " $ \\" <> prime aname' <> " -> do" indent $ do wrapped <- wrapArray (prime aname')- line $ "return " ++ wrapped- return $ "maybe" ++ ucFirst aname')+ line $ "return " <> wrapped+ return $ "maybe" <> ucFirst aname') t -> do weAlloc <- isJust <$> requiresAlloc t peeked <- if weAlloc@@ -683,24 +684,24 @@ let wrap ptr = convert ptr $ fToH (argType arg) transfer' wrapMaybe arg >>= bool (wrap peeked)- (do line $ "maybe" ++ ucFirst peeked- ++ " <- convertIfNonNull " ++ peeked- ++ " $ \\" ++ prime peeked ++ " -> do"+ (do line $ "maybe" <> ucFirst peeked+ <> " <- convertIfNonNull " <> peeked+ <> " $ \\" <> prime peeked <> " -> do" indent $ do wrapped <- wrap (prime peeked)- line $ "return " ++ wrapped- return $ "maybe" ++ ucFirst peeked)+ line $ "return " <> wrapped+ return $ "maybe" <> ucFirst peeked) -- Free the memory associated with the out argument freeContainerType transfer' t peeked undefined return result - returnResult :: String -> [String] -> CodeGen ()+ returnResult :: Text -> [Text] -> CodeGen () returnResult result pps = if ignoreReturn || returnType callable == TBasicType TVoid then case pps of [] -> line "return ()"- (pp:[]) -> line $ "return " ++ pp- _ -> line $ "return (" ++ intercalate ", " pps ++ ")"+ (pp:[]) -> line $ "return " <> pp+ _ -> line $ "return (" <> T.intercalate ", " pps <> ")" else case pps of- [] -> line $ "return " ++ result- _ -> line $ "return (" ++ intercalate ", " (result : pps) ++ ")"+ [] -> line $ "return " <> result+ _ -> line $ "return (" <> T.intercalate ", " (result : pps) <> ")"
src/GI/Code.hs view
@@ -1,56 +1,91 @@ module GI.Code ( Code(..)+ , ModuleInfo(..)+ , ModuleFlag(..) , BaseCodeGen , CodeGen , ExcCodeGen , CGError(..) , genCode , evalCodeGen- , codeToString++ , writeModuleTree+ , writeModuleCode+ , codeToText+ , transitiveModuleDeps+ , loadDependency , getDeps- , recurse- , recurse'+ , recurseWithAPIs+ , handleCGExc , describeCGError , notImplementedError , badIntroError , missingInfoError+ , indent+ , bline , line , blank , group- , foreignImport+ , hsBoot+ , submodule+ , setLanguagePragmas+ , setModuleFlags+ , addModuleDocumentation + , exportToplevel+ , exportDecl+ , exportMethod+ , exportProperty+ , exportSignal+ , findAPI , findAPIByName , getAPIs- , injectAPIs , config+ , currentModule++ -- From Data.Monoid, for convenience+ , (<>) ) where #if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))+import Control.Applicative ((<$>), (<*>))+import Data.Monoid (Monoid(..)) #endif-import Control.Monad.RWS+import Control.Monad.Reader+import Control.Monad.State.Strict import Control.Monad.Except+import qualified Data.Foldable as F+import Data.Maybe (fromMaybe, catMaybes)+import Data.Monoid ((<>)) import Data.Sequence (Seq, ViewL ((:<)), (><), (|>), (<|))-import qualified Data.Map as M+import qualified Data.Map.Strict as M import qualified Data.Sequence as S import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO +import System.Directory (createDirectoryIfMissing)+import System.FilePath (joinPath, takeDirectory)+ import GI.API (API, Name(..)) import GI.Config (Config(..)) import GI.Type (Type(..))+import GI.Util (tshow, terror, ucFirst, padTo)+import GI.ProjectInfo (authors, license, maintainers)+import GI.GIR.Documentation (Documentation(..)) data Code- = NoCode- | Line String- | Indent Code- | Sequence (Seq Code)- | ForeignImport Code- | Group Code+ = NoCode -- ^ No code+ | Line Text -- ^ A single line, indented to current indentation+ | Indent Code -- ^ Indented region+ | Sequence (Seq Code) -- ^ The basic sequence of code+ | Group Code -- ^ A grouped set of lines deriving (Eq, Show) instance Monoid Code where@@ -64,18 +99,82 @@ a `mappend` (Sequence b) = Sequence (a <| b) a `mappend` b = Sequence (a <| b <| S.empty) -type Deps = Set.Set String-data CodeGenState = CodeGenState {- moduleDeps :: Deps,- loadedAPIs :: M.Map Name API }+type Deps = Set.Set Text+type ModuleName = [Text] -data CGError = CGErrorNotImplemented String- | CGErrorBadIntrospectionInfo String- | CGErrorMissingInfo String+-- | Subsection of the haddock documentation where the export should+-- be located.+type HaddockSection = Text++-- | Symbol to export.+type SymbolName = Text++-- | Possible exports for a given module. Every export type+-- constructor has two parameters: the section of the haddocks where+-- it should appear, and the symbol name to export in the export list+-- of the module.+data Export = Export {+ exportType :: ExportType -- ^ Which kind of export.+ , exportSymbol :: SymbolName -- ^ Actual symbol to export.+ } deriving (Show, Eq, Ord)++-- | Possible types of exports.+data ExportType = ExportTypeDecl -- ^ A type declaration.+ | ExportToplevel -- ^ An export in no specific section.+ | ExportMethod HaddockSection -- ^ A method for a struct/union, etc.+ | ExportProperty HaddockSection -- ^ A property for an object/interface.+ | ExportSignal HaddockSection -- ^ A signal for an object/interface.+ | ExportModule -- ^ Reexport of a whole module.+ deriving (Show, Eq, Ord)++-- | Information on a generated module.+data ModuleInfo = ModuleInfo {+ moduleName :: ModuleName -- ^ Full module name: ["GI", "Gtk", "Label"].+ , moduleCode :: Code -- ^ Generated code for the module.+ , bootCode :: Code -- ^ Interface going into the .hs-boot file.+ , submodules :: M.Map Text ModuleInfo -- ^ Indexed by the relative+ -- module name.+ , moduleDeps :: Deps -- ^ Set of dependencies for this module.+ , moduleExports :: Seq Export -- ^ Exports for the module.+ , modulePragmas :: Set.Set Text -- ^ Set of language pragmas for the module.+ , moduleFlags :: Set.Set ModuleFlag -- ^ Flags for the module.+ , moduleDoc :: Maybe Text -- ^ Documentation for the module.+ }++-- | Flags for module code generation.+data ModuleFlag = ImplicitPrelude -- ^ Use the standard prelude,+ -- instead of the haskell-gi-base short one.+ | NoTypesImport -- ^ Do not import a "Types" submodule.+ | NoCallbacksImport-- ^ Do not import a "Callbacks" submodule.+ | Reexport -- ^ Reexport the module (as is) from .Types+ deriving (Show, Eq, Ord)++-- | Generate the empty module.+emptyModule :: ModuleName -> ModuleInfo+emptyModule m = ModuleInfo { moduleName = m+ , moduleCode = NoCode+ , bootCode = NoCode+ , submodules = M.empty+ , moduleDeps = Set.empty+ , moduleExports = S.empty+ , modulePragmas = Set.empty+ , moduleFlags = Set.empty+ , moduleDoc = Nothing+ }++-- | Information for the code generator.+data CodeGenConfig = CodeGenConfig {+ hConfig :: Config -- ^ Ambient config.+ , loadedAPIs :: M.Map Name API -- ^ APIs available to the generator.+ }++data CGError = CGErrorNotImplemented Text+ | CGErrorBadIntrospectionInfo Text+ | CGErrorMissingInfo Text deriving (Show) type BaseCodeGen excType a =- RWST Config Code CodeGenState (ExceptT excType IO) a+ ReaderT CodeGenConfig (StateT ModuleInfo (ExceptT excType IO)) a -- | The code generator monad, for generators that cannot throw -- errors. The fact that they cannot throw errors is encoded in the@@ -89,110 +188,172 @@ -- | Code generators that can throw errors. type ExcCodeGen a = BaseCodeGen CGError a --- | Due to the `forall` in the definition of `CodeGen`, if we want to--- run the monad transformer stack until we get an `IO` action, our--- only option is ignoring the possible error code from--- `runExceptT`. This is perfectly safe, since there is no way to--- construct a computation in the `CodeGen` monad that throws an--- exception, due to the higher rank type.-unwrapCodeGen :: Config -> CodeGenState -> CodeGen a ->- IO (a, CodeGenState, Code)-unwrapCodeGen cfg state cg =- runExceptT (runRWST cg cfg state) >>= \case- Left _ -> error "unwrapCodeGen:: The impossible happened!"- Right (r, s, c) -> return (r, s, c)+-- | Run a `CodeGen` with given `Config` and initial `ModuleInfo`,+-- returning either the resulting exception, or the result and final+-- state of the codegen.+runCodeGen :: BaseCodeGen e a -> CodeGenConfig -> ModuleInfo ->+ IO (Either e (a, ModuleInfo))+runCodeGen cg cfg state = runExceptT (runStateT (runReaderT cg cfg) state) --- | Run the given code generator, merging its resulting state into--- the ambient state, and turning its output into a value.-recurse :: BaseCodeGen e a -> BaseCodeGen e (a, Code)-recurse cg = do- r <- ask- oldState <- get- liftIO (runExceptT $ runRWST cg r oldState) >>= \case- Left e -> throwError e- Right (r, st, c) -> put (mergeState oldState st) >> return (r, c)+-- | This is useful when we plan run a subgenerator, and `mconcat` the+-- result to the original structure later.+cleanInfo :: ModuleInfo -> ModuleInfo+cleanInfo info = info { moduleCode = NoCode, submodules = M.empty,+ bootCode = NoCode, moduleExports = S.empty,+ moduleDoc = Nothing } +-- | Run the given code generator using the state and config of an+-- ambient CodeGen, but without adding the generated code to+-- `moduleCode`, instead returning it explicitly.+recurseCG :: BaseCodeGen e a -> BaseCodeGen e (a, Code)+recurseCG cg = do+ cfg <- ask+ oldInfo <- get+ -- Start the subgenerator with no code and no submodules.+ let info = cleanInfo oldInfo+ liftIO (runCodeGen cg cfg info) >>= \case+ Left e -> throwError e+ Right (r, new) -> put (mergeInfoState oldInfo new) >>+ return (r, moduleCode new)++-- | Like `recurse`, giving explicitly the set of loaded APIs for the+-- subgenerator.+recurseWithAPIs :: M.Map Name API -> CodeGen () -> CodeGen ()+recurseWithAPIs apis cg = do+ cfg <- ask+ oldInfo <- get+ -- Start the subgenerator with no code and no submodules.+ let info = cleanInfo oldInfo+ cfg' = cfg {loadedAPIs = apis}+ liftIO (runCodeGen cg cfg' info) >>= \case+ Left e -> throwError e+ Right (_, new) -> put (mergeInfo oldInfo new)++-- | Merge everything but the generated code for the two given `ModuleInfo`.+mergeInfoState :: ModuleInfo -> ModuleInfo -> ModuleInfo+mergeInfoState oldState newState =+ let newDeps = Set.union (moduleDeps oldState) (moduleDeps newState)+ newSubmodules = M.unionWith mergeInfo (submodules oldState) (submodules newState)+ newExports = moduleExports oldState <> moduleExports newState+ newPragmas = Set.union (modulePragmas oldState) (modulePragmas newState)+ newFlags = Set.union (moduleFlags oldState) (moduleFlags newState)+ newBoot = bootCode oldState <> bootCode newState+ newDoc = moduleDoc oldState <> moduleDoc newState+ in oldState {moduleDeps = newDeps, submodules = newSubmodules,+ moduleExports = newExports, modulePragmas = newPragmas,+ moduleFlags = newFlags, bootCode = newBoot,+ moduleDoc = newDoc }++-- | Merge the infos, including code too.+mergeInfo :: ModuleInfo -> ModuleInfo -> ModuleInfo+mergeInfo oldInfo newInfo =+ let info = mergeInfoState oldInfo newInfo+ in info { moduleCode = moduleCode oldInfo <> moduleCode newInfo }++-- | Add the given submodule to the list of submodules of the current+-- module.+addSubmodule :: Text -> ModuleInfo -> ModuleInfo -> ModuleInfo+addSubmodule modName submodule current = current { submodules = M.insertWith mergeInfo modName submodule (submodules current)}++-- | Run the given CodeGen in order to generate a submodule of the+-- current module.+submodule :: Text -> BaseCodeGen e () -> BaseCodeGen e ()+submodule modName cg = do+ cfg <- ask+ oldInfo <- get+ let info = emptyModule (moduleName oldInfo ++ [modName])+ liftIO (runCodeGen cg cfg info) >>= \case+ Left e -> throwError e+ Right (_, smInfo) -> modify' (addSubmodule modName smInfo)+ -- | Try running the given `action`, and if it fails run `fallback` -- instead. handleCGExc :: (CGError -> CodeGen a) -> ExcCodeGen a -> CodeGen a-handleCGExc fallback action = do- r <- ask- oldState <- get- liftIO (runExceptT $ runRWST action r oldState) >>= \case+handleCGExc fallback+ action = do+ cfg <- ask+ oldInfo <- get+ let info = cleanInfo oldInfo+ liftIO (runCodeGen action cfg info) >>= \case Left e -> fallback e- Right (r, s, c) -> do- put $ mergeState oldState s- tell c+ Right (r, newInfo) -> do+ put (mergeInfo oldInfo newInfo) return r -emptyState :: CodeGenState-emptyState = CodeGenState {moduleDeps = Set.empty- ,loadedAPIs = M.empty }-+-- | Return the currently loaded set of dependencies. getDeps :: CodeGen Deps getDeps = moduleDeps <$> get -getAPIs :: CodeGen (M.Map Name API)-getAPIs = loadedAPIs <$> get+-- | Return the ambient configuration for the code generator.+config :: CodeGen Config+config = hConfig <$> ask --- | Inject the given APIs into loaded set.-injectAPIs :: [(Name, API)] -> CodeGen()-injectAPIs newAPIs = do- oldState <- get- put $ oldState {loadedAPIs =- M.union (loadedAPIs oldState) (M.fromList newAPIs)}+-- | Return the name of the current module.+currentModule :: CodeGen Text+currentModule = do+ s <- get+ return (T.intercalate "." (moduleName s)) --- | Merge two states of a code generator.-mergeState :: CodeGenState -> CodeGenState -> CodeGenState-mergeState oldState newState =- -- If no dependencies were added we do not need to merge.- if Set.size (moduleDeps oldState) /= Set.size (moduleDeps newState)- then let newDeps = Set.union (moduleDeps oldState) (moduleDeps newState)- newAPIs = M.union (loadedAPIs oldState) (loadedAPIs newState)- in CodeGenState {moduleDeps = newDeps, loadedAPIs = newAPIs}- else oldState+-- | Return the list of APIs available to the generator.+getAPIs :: CodeGen (M.Map Name API)+getAPIs = loadedAPIs <$> ask --- | Run a code generator, and return the dependencies encountered--- when generating code.-genCode :: Config -> M.Map Name API -> CodeGen () -> IO (Deps, Code)-genCode cfg apis cg = do- (_, st, code) <- unwrapCodeGen cfg (emptyState {loadedAPIs = apis}) cg- return (moduleDeps st, code)+-- | Due to the `forall` in the definition of `CodeGen`, if we want to+-- run the monad transformer stack until we get an `IO` action, our+-- only option is ignoring the possible error code from+-- `runExceptT`. This is perfectly safe, since there is no way to+-- construct a computation in the `CodeGen` monad that throws an+-- exception, due to the higher rank type.+unwrapCodeGen :: CodeGen a -> CodeGenConfig -> ModuleInfo ->+ IO (a, ModuleInfo)+unwrapCodeGen cg cfg info =+ runCodeGen cg cfg info >>= \case+ Left _ -> error "unwrapCodeGen:: The impossible happened!"+ Right (r, newInfo) -> return (r, newInfo) --- | Like `genCode`, but keep the final value and output, discarding--- the state.-evalCodeGen :: Config -> M.Map Name API -> CodeGen a -> IO (a, Code)-evalCodeGen cfg apis cg = do- (r, _, code) <- unwrapCodeGen cfg (emptyState {loadedAPIs = apis}) cg- return (r, code)+-- | Like `evalCodeGen`, but discard the resulting output value.+genCode :: Config -> M.Map Name API -> ModuleName -> CodeGen () ->+ IO ModuleInfo+genCode cfg apis mName cg = snd <$> evalCodeGen cfg apis mName cg --- | Like `recurse`, but for generators returning a unit value, where--- we can just drop the result.-recurse' :: CodeGen () -> CodeGen Code-recurse' cg = snd <$> recurse cg+-- | Run a code generator, and return the information for the+-- generated module together with the return value of the generator.+evalCodeGen :: Config -> M.Map Name API -> ModuleName -> CodeGen a ->+ IO (a, ModuleInfo)+evalCodeGen cfg apis mName cg = do+ let initialInfo = emptyModule mName+ cfg' = CodeGenConfig {hConfig = cfg, loadedAPIs = apis}+ unwrapCodeGen cg cfg' initialInfo -- | Mark the given dependency as used by the module.-loadDependency :: String -> CodeGen ()+loadDependency :: Text -> CodeGen () loadDependency name = do deps <- getDeps unless (Set.member name deps) $ do let newDeps = Set.insert name deps modify' $ \s -> s {moduleDeps = newDeps} +-- | Return the transitive set of dependencies, i.e. the union of+-- those of the module and (transitively) its submodules.+transitiveModuleDeps :: ModuleInfo -> Deps+transitiveModuleDeps minfo =+ Set.unions (moduleDeps minfo+ : map transitiveModuleDeps (M.elems $ submodules minfo))+ -- | Give a friendly textual description of the error for presenting -- to the user.-describeCGError :: CGError -> String-describeCGError (CGErrorNotImplemented e) = "Not implemented: " ++ show e-describeCGError (CGErrorBadIntrospectionInfo e) = "Bad introspection data: " ++ show e-describeCGError (CGErrorMissingInfo e) = "Missing info: " ++ show e+describeCGError :: CGError -> Text+describeCGError (CGErrorNotImplemented e) = "Not implemented: " <> tshow e+describeCGError (CGErrorBadIntrospectionInfo e) = "Bad introspection data: " <> tshow e+describeCGError (CGErrorMissingInfo e) = "Missing info: " <> tshow e -notImplementedError :: String -> ExcCodeGen a+notImplementedError :: Text -> ExcCodeGen a notImplementedError s = throwError $ CGErrorNotImplemented s -badIntroError :: String -> ExcCodeGen a+badIntroError :: Text -> ExcCodeGen a badIntroError s = throwError $ CGErrorBadIntrospectionInfo s -missingInfoError :: String -> ExcCodeGen a+missingInfoError :: Text -> ExcCodeGen a missingInfoError s = throwError $ CGErrorMissingInfo s findAPI :: Type -> CodeGen (Maybe API)@@ -206,44 +367,372 @@ case M.lookup n apis of Just api -> return api Nothing ->- error $ "couldn't find API description for " ++ ns ++ "." ++ name n+ terror $ "couldn't find API description for " <> ns <> "." <> name n -config :: CodeGen Config-config = ask+-- | Add some code to the current generator.+tellCode :: Code -> CodeGen ()+tellCode c = modify' (\s -> s {moduleCode = moduleCode s <> c}) -line :: String -> CodeGen ()-line = tell . Line+-- | Print out a (newline-terminated) line.+line :: Text -> CodeGen ()+line = tellCode . Line +-- | Print out the given line both to the normal module, and to the+-- HsBoot file.+bline :: Text -> CodeGen ()+bline l = hsBoot (line l) >> line l++-- | A blank line blank :: CodeGen () blank = line "" +-- | Increase the indent level for code generation. indent :: BaseCodeGen e a -> BaseCodeGen e a indent cg = do- (x, code) <- recurse cg- tell $ Indent code+ (x, code) <- recurseCG cg+ tellCode (Indent code) return x +-- | Group a set of related code. group :: BaseCodeGen e a -> BaseCodeGen e a group cg = do- (x, code) <- recurse cg- tell $ Group code+ (x, code) <- recurseCG cg+ tellCode (Group code) blank return x -foreignImport :: BaseCodeGen e a -> BaseCodeGen e a-foreignImport cg = do- (a, c) <- recurse cg- tell $ ForeignImport c- return a+-- | Write the given code into the .hs-boot file for the current module.+hsBoot :: BaseCodeGen e a -> BaseCodeGen e a+hsBoot cg = do+ (x, code) <- recurseCG cg+ modify' (\s -> s{bootCode = bootCode s <> code})+ return x -codeToString c = unlines $ str 0 c []- where str _ NoCode cont = cont- str n (Line s) cont = (replicate (n * 4) ' ' ++ s) : cont- str n (Indent c) cont = str (n + 1) c cont- str n (ForeignImport c) cont = str n c cont- str n (Sequence s) cont = deseq n (S.viewl s) cont- -- str n (Sequence s) cont = F.foldr (\code rest -> str n code : rest) cont s- str n (Group c) cont = str n c cont+-- | Add a export to the current module.+export :: Export -> CodeGen ()+export e =+ modify' $ \s -> s{moduleExports = moduleExports s |> e} - deseq _ S.EmptyL cont = cont- deseq n (c :< cs) cont = str n c (deseq n (S.viewl cs) cont)+-- | Export a toplevel (i.e. belonging to no section) symbol.+exportToplevel :: SymbolName -> CodeGen ()+exportToplevel t = export (Export ExportToplevel t)++-- | Add a type declaration-related export.+exportDecl :: SymbolName -> CodeGen ()+exportDecl d = export (Export ExportTypeDecl d)++-- | Add a method export under the given section.+exportMethod :: HaddockSection -> SymbolName -> CodeGen ()+exportMethod s n = export (Export (ExportMethod s) n)++-- | Add a property-related export under the given section.+exportProperty :: HaddockSection -> SymbolName -> CodeGen ()+exportProperty s n = export (Export (ExportProperty s) n)++-- | Add a signal-related export under the given section.+exportSignal :: HaddockSection -> SymbolName -> CodeGen ()+exportSignal s n = export (Export (ExportSignal s) n)++-- | Set the language pragmas for the current module.+setLanguagePragmas :: [Text] -> CodeGen ()+setLanguagePragmas ps =+ modify' $ \s -> s{modulePragmas = Set.fromList ps}++-- | Set the given flags for the module.+setModuleFlags :: [ModuleFlag] -> CodeGen ()+setModuleFlags flags =+ modify' $ \s -> s{moduleFlags = Set.fromList flags}++-- | Add the given text to the module-level documentation for the+-- module being generated.+addModuleDocumentation :: Maybe Documentation -> CodeGen ()+addModuleDocumentation Nothing = return ()+addModuleDocumentation (Just doc) =+ modify' $ \s -> s{moduleDoc = moduleDoc s <> Just (docText doc)}++-- | Return a text representation of the `Code`.+codeToText :: Code -> Text+codeToText c = T.concat $ str 0 c []+ where+ str :: Int -> Code -> [Text] -> [Text]+ str _ NoCode cont = cont+ str n (Line s) cont = paddedLine n s : cont+ str n (Indent c) cont = str (n + 1) c cont+ str n (Sequence s) cont = deseq n (S.viewl s) cont+ str n (Group c) cont = str n c cont++ deseq _ S.EmptyL cont = cont+ deseq n (c :< cs) cont = str n c (deseq n (S.viewl cs) cont)++-- | Pad a line to the given number of leading spaces, and add a+-- newline at the end.+paddedLine :: Int -> Text -> Text+paddedLine n s = T.replicate (n * 4) " " <> s <> "\n"++-- | Put a (padded) comma at the end of the text.+comma :: Text -> Text+comma s = padTo 40 s <> ","++-- | Format the list of exported modules.+formatExportedModules :: [Export] -> Maybe Text+formatExportedModules [] = Nothing+formatExportedModules exports =+ Just . T.concat . map ( paddedLine 1+ . comma+ . ("module " <>)+ . exportSymbol)+ . filter ((== ExportModule) . exportType) $ exports++-- | Format the toplevel exported symbols.+formatToplevel :: [Export] -> Maybe Text+formatToplevel [] = Nothing+formatToplevel exports =+ Just . T.concat . map (paddedLine 1 . comma . exportSymbol)+ . filter ((== ExportToplevel) . exportType) $ exports++-- | Format the type declarations section.+formatTypeDecls :: [Export] -> Maybe Text+formatTypeDecls exports =+ let exportedTypes = filter ((== ExportTypeDecl) . exportType) exports+ in if exportedTypes == []+ then Nothing+ else Just . T.unlines $ [ "-- * Exported types"+ , T.concat . map ( paddedLine 1+ . comma+ . exportSymbol )+ $ exportedTypes ]++-- | Format a given section made of subsections.+formatSection :: Text -> (Export -> Maybe (HaddockSection, SymbolName)) ->+ [Export] -> Maybe Text+formatSection section filter exports =+ if M.null exportedSubsections+ then Nothing+ else Just . T.unlines $ [" -- * " <> section+ , ( T.unlines+ . map formatSubsection+ . M.toList ) exportedSubsections]++ where+ filteredExports :: [(HaddockSection, SymbolName)]+ filteredExports = catMaybes (map filter exports)++ exportedSubsections :: M.Map HaddockSection (Set.Set SymbolName)+ exportedSubsections = foldr extract M.empty filteredExports++ extract :: (HaddockSection, SymbolName) ->+ M.Map Text (Set.Set Text) -> M.Map Text (Set.Set Text)+ extract (subsec, m) secs =+ M.insertWith Set.union subsec (Set.singleton m) secs++ formatSubsection :: (HaddockSection, Set.Set SymbolName) -> Text+ formatSubsection (subsec, symbols) =+ T.unlines [ "-- ** " <> subsec+ , ( T.concat+ . map (paddedLine 1 . comma)+ . Set.toList ) symbols]++-- | Format the list of methods.+formatMethods :: [Export] -> Maybe Text+formatMethods = formatSection "Methods" toMethod+ where toMethod :: Export -> Maybe (HaddockSection, SymbolName)+ toMethod (Export (ExportMethod s) m) = Just (s, m)+ toMethod _ = Nothing++-- | Format the list of properties.+formatProperties :: [Export] -> Maybe Text+formatProperties = formatSection "Properties" toProperty+ where toProperty :: Export -> Maybe (HaddockSection, SymbolName)+ toProperty (Export (ExportProperty s) m) = Just (s, m)+ toProperty _ = Nothing++-- | Format the list of signals.+formatSignals :: [Export] -> Maybe Text+formatSignals = formatSection "Signals" toSignal+ where toSignal :: Export -> Maybe (HaddockSection, SymbolName)+ toSignal (Export (ExportSignal s) m) = Just (s, m)+ toSignal _ = Nothing++-- | Format the given export list. This is just the inside of the+-- parenthesis.+formatExportList :: [Export] -> Text+formatExportList exports =+ T.unlines . catMaybes $ [ formatExportedModules exports+ , formatToplevel exports+ , formatTypeDecls exports+ , formatMethods exports+ , formatProperties exports+ , formatSignals exports ]++-- | Write down the list of language pragmas.+languagePragmas :: [Text] -> Text+languagePragmas [] = ""+languagePragmas ps = "{-# LANGUAGE " <> T.intercalate ", " ps <> " #-}\n"++-- | Standard fields for every module.+standardFields :: Text+standardFields = T.unlines [ "Copyright : " <> authors+ , "License : " <> license+ , "Maintainer : " <> maintainers ]++-- | The haddock header for the module, including optionally a description.+moduleHaddock :: Maybe Text -> Text+moduleHaddock Nothing = T.unlines ["{- |", standardFields <> "-}"]+moduleHaddock (Just description) = T.unlines ["{- |", standardFields,+ description, "-}"]++-- | Generic module prelude. We reexport all of the submodules.+modulePrelude :: Text -> [Export] -> [Text] -> Text+modulePrelude name [] [] = "module " <> name <> " () where\n"+modulePrelude name exports [] =+ "module " <> name <> "\n ( "+ <> formatExportList exports+ <> " ) where\n"+modulePrelude name [] reexportedModules =+ "module " <> name <> "\n ( "+ <> formatExportList (map (Export ExportModule) reexportedModules)+ <> " ) where\n\n"+ <> T.unlines (map ("import " <>) reexportedModules)+modulePrelude name exports reexportedModules =+ "module " <> name <> "\n ( "+ <> formatExportList (map (Export ExportModule) reexportedModules)+ <> "\n , "+ <> formatExportList exports+ <> " ) where\n\n"+ <> T.unlines (map ("import " <>) reexportedModules)++-- | Code for loading the needed dependencies.+importDeps :: [Text] -> Text+importDeps [] = ""+importDeps deps = T.unlines . map toImport $ deps+ where toImport :: Text -> Text+ toImport dep = let ucDep = ucFirst dep+ in "import qualified GI." <> ucDep <> " as " <> ucDep++-- | Standard imports.+moduleImports :: Text+moduleImports = T.unlines [ "import Prelude ()"+ , "import Data.GI.Base.ShortPrelude"+ , ""+ , "import qualified Data.Text as T"+ , "import qualified Data.ByteString.Char8 as B"+ , "import qualified Data.Map as Map" ]++-- | Write to disk the code for a module, under the given base+-- directory. Does not write submodules recursively, for that use+-- `writeModuleTree`.+writeModuleInfo :: Bool -> Maybe FilePath -> ModuleInfo -> IO ()+writeModuleInfo verbose dirPrefix minfo = do+ let submoduleNames = map (moduleName) (M.elems (submodules minfo))+ -- We reexport any submodules.+ submoduleExports = map dotModuleName submoduleNames+ fname = moduleNameToPath dirPrefix (moduleName minfo) ".hs"+ dirname = takeDirectory fname+ code = codeToText (moduleCode minfo)+ pragmas = languagePragmas (Set.toList $ modulePragmas minfo)+ prelude = modulePrelude (dotModuleName $ moduleName minfo)+ (F.toList (moduleExports minfo))+ submoduleExports+ imports = if ImplicitPrelude `Set.member` moduleFlags minfo+ then ""+ else moduleImports+ deps = importDeps (Set.toList $ moduleDeps minfo)+ pkgRoot = take 2 (moduleName minfo)+ typesModule = pkgRoot ++ ["Types"]+ types = if moduleName minfo == typesModule ||+ NoTypesImport `Set.member` moduleFlags minfo+ then ""+ else "import " <> dotModuleName typesModule+ callbacksModule = pkgRoot ++ ["Callbacks"]+ callbacks = if moduleName minfo == callbacksModule ||+ NoCallbacksImport `Set.member` moduleFlags minfo+ then ""+ else "import " <> dotModuleName callbacksModule+ haddock = moduleHaddock (moduleDoc minfo)++ when verbose $ putStrLn ((T.unpack . dotModuleName . moduleName) minfo+ ++ " -> " ++ fname)+ createDirectoryIfMissing True dirname+ TIO.writeFile fname (T.unlines [pragmas, haddock, prelude,+ imports, types, callbacks, deps, code])+ when (bootCode minfo /= NoCode) $ do+ let bootFName = moduleNameToPath dirPrefix (moduleName minfo) ".hs-boot"+ TIO.writeFile bootFName (genHsBoot minfo)++-- | Generate the .hs-boot file for the given module.+genHsBoot :: ModuleInfo -> Text+genHsBoot minfo =+ "module " <> (dotModuleName . moduleName) minfo <> " where\n\n" <>+ moduleImports <> "\n" <>+ codeToText (bootCode minfo)++-- | Construct the filename corresponding to the given module.+moduleNameToPath :: Maybe FilePath -> ModuleName -> FilePath -> FilePath+moduleNameToPath dirPrefix mn ext =+ joinPath (fromMaybe "" dirPrefix : map T.unpack mn) ++ ext++-- | Turn an abstract module name into its dotted representation. For+-- instance, ["GI", "Gtk", "Types"] -> GI.Gtk.Types.+dotModuleName :: ModuleName -> Text+dotModuleName mn = T.intercalate "." mn++-- | Write down the code for a module and its submodules to disk under+-- the given base directory. It returns the list of written modules.+writeModuleCode :: Bool -> Maybe FilePath -> ModuleInfo -> IO [Text]+writeModuleCode verbose dirPrefix minfo = do+ submoduleNames <- concat <$> forM (M.elems (submodules minfo))+ (writeModuleCode verbose dirPrefix)+ writeModuleInfo verbose dirPrefix minfo+ return $ (dotModuleName (moduleName minfo) : submoduleNames)++-- | List of reexports from the ".Types" module.+typeReexports :: ModuleName -> [Text] -> Text+typeReexports typesModule bootFiles =+ "module " <> dotModuleName typesModule <>+ "\n ( " <>+ formatExportList (map (Export ExportModule) bootFiles) <>+ " ) where\n\n"++-- | Import the given (.hs-boot) modules.+hsBootImports :: [Text] -> Text+hsBootImports bootFiles =+ T.unlines (map ("import {-# SOURCE #-} " <>) bootFiles)++-- | Write down the ".Types" file reexporting all the interfaces+-- defined in .hs-boot files. Returns the module name for the ".Types" file.+writeTypes :: Maybe FilePath -> ModuleInfo -> IO Text+writeTypes dirPrefix minfo = do+ let pkgRoot = take 2 (moduleName minfo)+ typesModule = pkgRoot ++ ["Types"]+ fname = moduleNameToPath dirPrefix typesModule ".hs"+ dirname = takeDirectory fname+ bootfiles = map (dotModuleName . moduleName) (collectBootFiles minfo)+ reexports = map (dotModuleName . moduleName) (collectReexports minfo)+ exports = typeReexports typesModule (bootfiles ++ reexports)++ createDirectoryIfMissing True dirname+ TIO.writeFile fname (T.unlines [exports, hsBootImports bootfiles,+ T.unlines (map ("import " <>) reexports) ])+ return (dotModuleName typesModule)++ where collectBootFiles :: ModuleInfo -> [ModuleInfo]+ collectBootFiles minfo =+ let sms = M.elems (submodules minfo)+ in if bootCode minfo /= NoCode+ then minfo : concatMap collectBootFiles sms+ else concatMap collectBootFiles sms++ collectReexports :: ModuleInfo -> [ModuleInfo]+ collectReexports minfo =+ let sms = M.elems (submodules minfo)+ in if Reexport `Set.member` moduleFlags minfo+ then minfo : concatMap collectReexports sms+ else concatMap collectReexports sms++-- | Write down the code for a module and its submodules to disk under+-- the given base directory. This also writes the submodules, and a+-- "Types" submodule reexporting all interfaces defined in .hs-boot+-- files. It returns the list of written modules.+writeModuleTree :: Bool -> Maybe FilePath -> ModuleInfo -> IO [Text]+writeModuleTree verbose dirPrefix minfo =+ (:) <$> writeTypes dirPrefix minfo <*> writeModuleCode verbose dirPrefix minfo
src/GI/CodeGen.hs view
@@ -1,7 +1,6 @@ module GI.CodeGen ( genConstant , genFunction- , genPrelude , genModule ) where @@ -10,12 +9,10 @@ import Data.Traversable (traverse) #endif import Control.Monad (forM, forM_, when, unless, filterM)-import Control.Monad.Writer (tell)-import Data.List (intercalate, nub)+import Data.List (nub) import Data.Tuple (swap) import Data.Maybe (fromJust, fromMaybe) import qualified Data.Map as M-import qualified Data.Set as S import qualified Data.Text as T import Data.Text (Text) @@ -28,43 +25,49 @@ import GI.Code import GI.GObject import GI.Inheritance (instanceTree)+import GI.Properties (genInterfaceProperties, genObjectProperties)+import GI.OverloadedSignals (genInterfaceSignals, genObjectSignals) import GI.Signal (genSignal, genCallback) import GI.Struct (genStructOrUnionFields, extractCallbacksInStruct, fixAPIStructs, ignoreStruct)-import GI.SymbolNaming (upperName, ucFirst, classConstraint, noName)+import GI.SymbolNaming (upperName, classConstraint, noName) import GI.Type+import GI.Util (tshow) genFunction :: Name -> Function -> CodeGen ()-genFunction n (Function symbol throws callable) = do- line $ "-- function " ++ T.unpack symbol- handleCGExc (\e -> line ("-- XXX Could not generate function "- ++ T.unpack symbol- ++ "\n-- Error was : " ++ describeCGError e))- (genCallable n symbol callable throws)+genFunction n (Function symbol throws callable) =+ submodule "Functions" $ group $ do+ line $ "-- function " <> symbol+ handleCGExc (\e -> line ("-- XXX Could not generate function "+ <> symbol+ <> "\n-- Error was : " <> describeCGError e))+ (genCallable n symbol callable throws) genBoxedObject :: Name -> Text -> CodeGen () genBoxedObject n typeInit = do name' <- upperName n group $ do- line $ "foreign import ccall \"" ++ T.unpack typeInit ++ "\" c_" ++- T.unpack typeInit ++ " :: "+ line $ "foreign import ccall \"" <> typeInit <> "\" c_" <>+ typeInit <> " :: " indent $ line "IO GType" group $ do- line $ "instance BoxedObject " ++ name' ++ " where"- indent $ line $ "boxedType _ = c_" ++ T.unpack typeInit+ line $ "instance BoxedObject " <> name' <> " where"+ indent $ line $ "boxedType _ = c_" <> typeInit + hsBoot $ line $ "instance BoxedObject " <> name' <> " where"+ genBoxedEnum :: Name -> Text -> CodeGen () genBoxedEnum n typeInit = do name' <- upperName n group $ do- line $ "foreign import ccall \"" ++ T.unpack typeInit ++ "\" c_" ++- T.unpack typeInit ++ " :: "+ line $ "foreign import ccall \"" <> typeInit <> "\" c_" <>+ typeInit <> " :: " indent $ line "IO GType" group $ do- line $ "instance BoxedEnum " ++ name' ++ " where"- indent $ line $ "boxedEnumType _ = c_" ++ T.unpack typeInit+ line $ "instance BoxedEnum " <> name' <> " where"+ indent $ line $ "boxedEnumType _ = c_" <> typeInit genEnumOrFlags :: Name -> Enumeration -> ExcCodeGen () genEnumOrFlags n@(Name ns name) (Enumeration fields eDomain maybeTypeInit storageBytes isDeprecated) = do@@ -72,99 +75,113 @@ -- which we assume to be of 32 bits. Fail early, instead of giving -- strange errors at runtime. when (sizeOf (0 :: CUInt) /= 4) $- notImplementedError $ "Unsupported CUInt size: " ++ show (sizeOf (0 :: CUInt))+ notImplementedError $ "Unsupported CUInt size: " <> tshow (sizeOf (0 :: CUInt)) when (storageBytes /= 4) $- notImplementedError $ "Storage of size /= 4 not supported : " ++ show storageBytes+ notImplementedError $ "Storage of size /= 4 not supported : " <> tshow storageBytes name' <- upperName n fields' <- forM fields $ \(fieldName, value) -> do- n <- upperName $ Name ns (name ++ "_" ++ T.unpack fieldName)+ n <- upperName $ Name ns (name <> "_" <> fieldName) return (n, value) line $ deprecatedPragma name' isDeprecated group $ do- line $ "data " ++ name' ++ " = "+ exportDecl (name' <> "(..)")+ line $ "data " <> name' <> " = " indent $ case fields' of ((fieldName, _value):fs) -> do- line $ " " ++ fieldName- forM_ fs $ \(n, _) -> line $ "| " ++ n- line $ "| Another" ++ name' ++ " Int"+ line $ " " <> fieldName+ forM_ fs $ \(n, _) -> line $ "| " <> n+ line $ "| Another" <> name' <> " Int" line "deriving (Show, Eq)" _ -> return () group $ do- line $ "instance Enum " ++ name' ++ " where"+ line $ "instance Enum " <> name' <> " where" indent $ do forM_ fields' $ \(n, v) ->- line $ "fromEnum " ++ n ++ " = " ++ show v- line $ "fromEnum (Another" ++ name' ++ " k) = k"+ line $ "fromEnum " <> n <> " = " <> tshow v+ line $ "fromEnum (Another" <> name' <> " k) = k" let valueNames = M.toList . M.fromListWith (curry snd) $ map swap fields' blank indent $ do forM_ valueNames $ \(v, n) ->- line $ "toEnum " ++ show v ++ " = " ++ n- line $ "toEnum k = Another" ++ name' ++ " k"+ line $ "toEnum " <> tshow v <> " = " <> n+ line $ "toEnum k = Another" <> name' <> " k" maybe (return ()) (genErrorDomain name') eDomain maybe (return ()) (genBoxedEnum n) maybeTypeInit genEnum :: Name -> Enumeration -> CodeGen ()-genEnum n@(Name _ name) enum = do- line $ "-- Enum " ++ name+genEnum n@(Name _ name) enum = submodule "Enums" $ do+ line $ "-- Enum " <> name - handleCGExc (\e -> line $ "-- XXX Could not generate: " ++ describeCGError e)+ -- Reexported as-is by GI.Pkg.Types+ setModuleFlags [Reexport, NoTypesImport, NoCallbacksImport]++ handleCGExc (\e -> line $ "-- XXX Could not generate: " <> describeCGError e) (genEnumOrFlags n enum) -- Very similar to enums, but we also declare ourselves as members of -- the IsGFlag typeclass. genFlags :: Name -> Flags -> CodeGen ()-genFlags n@(Name _ name) (Flags enum) = do- line $ "-- Flags " ++ name+genFlags n@(Name _ name) (Flags enum) = submodule "Flags" $ do+ line $ "-- Flags " <> name - handleCGExc (\e -> line $ "-- XXX Could not generate: " ++ describeCGError e)+ -- Reexported as-is by GI.Pkg.Types+ setModuleFlags [Reexport, NoTypesImport, NoCallbacksImport]++ handleCGExc (\e -> line $ "-- XXX Could not generate: " <> describeCGError e) (do genEnumOrFlags n enum name' <- upperName n- group $ line $ "instance IsGFlag " ++ name')+ group $ line $ "instance IsGFlag " <> name') -genErrorDomain :: String -> Text -> CodeGen ()+genErrorDomain :: Text -> Text -> CodeGen () genErrorDomain name' domain = do group $ do- line $ "instance GErrorClass " ++ name' ++ " where"+ line $ "instance GErrorClass " <> name' <> " where" indent $ line $- "gerrorClassDomain _ = \"" ++ T.unpack domain ++ "\""+ "gerrorClassDomain _ = \"" <> domain <> "\"" -- Generate type specific error handling (saves a bit of typing, and -- it's clearer to read). group $ do- let catcher = "catch" ++ name'- line $ catcher ++ " ::"+ let catcher = "catch" <> name'+ line $ catcher <> " ::" indent $ do line "IO a ->"- line $ "(" ++ name' ++ " -> GErrorMessage -> IO a) ->"+ line $ "(" <> name' <> " -> GErrorMessage -> IO a) ->" line "IO a"- line $ catcher ++ " = catchGErrorJustDomain"+ line $ catcher <> " = catchGErrorJustDomain" group $ do- let handler = "handle" ++ name'- line $ handler ++ " ::"+ let handler = "handle" <> name'+ line $ handler <> " ::" indent $ do- line $ "(" ++ name' ++ " -> GErrorMessage -> IO a) ->"+ line $ "(" <> name' <> " -> GErrorMessage -> IO a) ->" line "IO a ->" line "IO a"- line $ handler ++ " = handleGErrorJustDomain"+ line $ handler <> " = handleGErrorJustDomain"+ exportToplevel ("catch" <> name')+ exportToplevel ("handle" <> name') genStruct :: Name -> Struct -> CodeGen () genStruct n s = unless (ignoreStruct n s) $ do- name' <- upperName n- line $ "-- struct " ++ name'+ name' <- upperName n - line $ "newtype " ++ name' ++ " = " ++ name' ++ " (ForeignPtr " ++ name' ++ ")"+ submodule "Structs" $ submodule name' $ do+ let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"+ hsBoot decl+ decl - noName name'+ addModuleDocumentation (structDocumentation s) when (structIsBoxed s) $ genBoxedObject n (fromJust $ structTypeInit s)+ exportDecl (name' <> ("(..)")) + noName name'+ -- Generate code for fields. genStructOrUnionFields n (structFields s) @@ -174,35 +191,37 @@ unless isFunction $ handleCGExc (\e -> line ("-- XXX Could not generate method "- ++ name' ++ "::" ++ name mn ++ "\n"- ++ "-- Error was : " ++ describeCGError e))+ <> name' <> "::" <> name mn <> "\n"+ <> "-- Error was : " <> describeCGError e)) (genMethod n mn f) genUnion :: Name -> Union -> CodeGen () genUnion n u = do name' <- upperName n - line $ "-- union " ++ name' ++ " "-- line $ "newtype " ++ name' ++ " = " ++ name' ++ " (ForeignPtr " ++ name' ++ ")"+ submodule "Unions" $ submodule name' $ do+ let decl = line $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"+ hsBoot decl+ decl - noName name'+ when (unionIsBoxed u) $+ genBoxedObject n (fromJust $ unionTypeInit u)+ exportDecl (name' <> "(..)") - when (unionIsBoxed u) $- genBoxedObject n (fromJust $ unionTypeInit u)+ noName name' - -- Generate code for fields.- genStructOrUnionFields n (unionFields u)+ -- Generate code for fields.+ genStructOrUnionFields n (unionFields u) - -- Methods- forM_ (unionMethods u) $ \(mn, f) ->- do isFunction <- symbolFromFunction (methodSymbol f)- unless isFunction $- handleCGExc- (\e -> line ("-- XXX Could not generate method "- ++ name' ++ "::" ++ name mn ++ "\n"- ++ "-- Error was : " ++ describeCGError e))- (genMethod n mn f)+ -- Methods+ forM_ (unionMethods u) $ \(mn, f) ->+ do isFunction <- symbolFromFunction (methodSymbol f)+ unless isFunction $+ handleCGExc+ (\e -> line ("-- XXX Could not generate method "+ <> name' <> "::" <> name mn <> "\n"+ <> "-- Error was : " <> describeCGError e))+ (genMethod n mn f) -- Add the implicit object argument to methods of an object. Since we -- are prepending an argument we need to adjust the offset of the@@ -265,10 +284,10 @@ }) = do name' <- upperName cn returnsGObject <- isGObject (returnType c)- line $ "-- method " ++ name' ++ "::" ++ name mn- line $ "-- method type : " ++ show t+ line $ "-- method " <> name' <> "::" <> name mn+ line $ "-- method type : " <> tshow t let -- Mangle the name to namespace it to the class.- mn' = mn { name = name cn ++ "_" ++ name mn }+ mn' = mn { name = name cn <> "_" <> name mn } let c' = if Constructor == t then fixConstructorReturnType returnsGObject cn c else c@@ -284,118 +303,127 @@ qualifiedParents <- traverse upperName parents group $ do- line $ "foreign import ccall \"" ++ T.unpack cn_ ++ "\""- indent $ line $ "c_" ++ T.unpack cn_ ++ " :: IO GType"+ line $ "foreign import ccall \"" <> cn_ <> "\""+ indent $ line $ "c_" <> cn_ <> " :: IO GType" group $ do- line $ "type instance ParentTypes " ++ name' ++ " = '[" ++- intercalate ", " qualifiedParents ++ "]"+ let parentObjectsType = name' <> "ParentTypes"+ line $ "type instance ParentTypes " <> name' <> " = " <> parentObjectsType+ line $ "type " <> parentObjectsType <> " = '[" <>+ T.intercalate ", " qualifiedParents <> "]" group $ do- line $ "instance GObject " ++ name' ++ " where"+ bline $ "instance GObject " <> name' <> " where" indent $ group $ do- line $ "gobjectIsInitiallyUnowned _ = " ++ show isIU- line $ "gobjectType _ = c_" ++ T.unpack cn_+ line $ "gobjectIsInitiallyUnowned _ = " <> tshow isIU+ line $ "gobjectType _ = c_" <> cn_ let className = classConstraint name' group $ do- line $ "class GObject o => " ++ className ++ " o"- line $ "instance (GObject o, IsDescendantOf " ++ name' ++ " o) => "- ++ className ++ " o"+ exportDecl className+ bline $ "class GObject o => " <> className <> " o"+ bline $ "instance (GObject o, IsDescendantOf " <> name' <> " o) => "+ <> className <> " o" -- Safe downcasting. group $ do- let safeCast = "to" ++ name'- line $ safeCast ++ " :: " ++ className ++ " o => o -> IO " ++ name'- line $ safeCast ++ " = unsafeCastTo " ++ name'+ let safeCast = "to" <> name'+ exportDecl safeCast+ line $ safeCast <> " :: " <> className <> " o => o -> IO " <> name'+ line $ safeCast <> " = unsafeCastTo " <> name' -- Wrap a given Object. We enforce that every Object that we wrap is a--- GObject. This is the case for everything expect the ParamSpec* set--- of objects, we deal with these separately. Notice that in the case--- that a non-GObject Object is passed, it is simply ignored silently--- by the handler in handleCGExc below.+-- GObject. This is the case for everything except the ParamSpec* set+-- of objects, we deal with these separately. genObject :: Name -> Object -> CodeGen ()-genObject n o = handleCGExc (\_ -> return ()) $ do+genObject n o = do name' <- upperName n-- line $ "-- object " ++ name' ++ " "- let t = (\(Name ns' n') -> TInterface ns' n') n isGO <- isGObject t- unless isGO $ notImplementedError $ "APIObject \"" ++ name' ++- "\" does not descend from GObject, it will be ignored." - line $ "newtype " ++ name' ++ " = " ++ name' ++ " (ForeignPtr " ++ name' ++ ")"+ if not isGO+ then line $ "-- APIObject \"" <> name' <>+ "\" does not descend from GObject, it will be ignored."+ else submodule "Objects" $ submodule name' $+ do+ bline $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"+ exportDecl (name' <> "(..)") - noName name'+ -- Type safe casting to parent objects, and implemented interfaces.+ isIU <- isInitiallyUnowned t+ parents <- instanceTree n+ genGObjectCasts isIU n (objTypeInit o) (parents <> objInterfaces o) - -- Type safe casting to parent objects, and implemented interfaces.- isIU <- isInitiallyUnowned t- parents <- instanceTree n- genGObjectCasts isIU n (objTypeInit o) (parents ++ objInterfaces o)+ noName name' - -- Methods- forM_ (objMethods o) $ \(mn, f) ->- handleCGExc- (\e -> line ("-- XXX Could not generate method "- ++ name' ++ "::" ++ name mn ++ "\n"- ++ "-- Error was : " ++ describeCGError e))- (genMethod n mn f)+ forM_ (objSignals o) $ \s ->+ handleCGExc+ (line . (T.concat ["-- XXX Could not generate signal ", name', "::"+ , sigName s+ , "\n", "-- Error was : "] <>) . describeCGError)+ (genSignal s n) - -- And finally signals- forM_ (objSignals o) $ \s ->- handleCGExc- (line . (concat ["-- XXX Could not generate signal ", name', "::"- , (T.unpack . sigName) s- , "\n", "-- Error was : "] ++) . describeCGError)- (genSignal s n)+ genObjectProperties n o+ genObjectSignals n o + -- Methods+ forM_ (objMethods o) $ \(mn, f) ->+ handleCGExc+ (\e -> line ("-- XXX Could not generate method "+ <> name' <> "::" <> name mn <> "\n"+ <> "-- Error was : " <> describeCGError e))+ (genMethod n mn f)+ genInterface :: Name -> Interface -> CodeGen () genInterface n iface = do- -- For each interface, we generate a class IFoo and a data structure- -- Foo. We only really need a separate Foo so that we can return- -- them from bound functions. In principle we might be able to do- -- something more elegant with existential types.- name' <- upperName n- line $ "-- interface " ++ name' ++ " "- line $ deprecatedPragma name' $ ifDeprecated iface- line $ "newtype " ++ name' ++ " = " ++ name' ++ " (ForeignPtr " ++ name' ++ ")" - noName name'+ submodule "Interfaces" $ submodule name' $ do+ line $ "-- interface " <> name' <> " "+ line $ deprecatedPragma name' $ ifDeprecated iface+ bline $ "newtype " <> name' <> " = " <> name' <> " (ForeignPtr " <> name' <> ")"+ exportDecl (name' <> "(..)") - isGO <- apiIsGObject n (APIInterface iface)- if isGO- then do- let cn_ = fromMaybe (error "GObject derived interface without a type!") (ifTypeInit iface)- isIU <- apiIsInitiallyUnowned n (APIInterface iface)- gobjectPrereqs <- filterM nameIsGObject (ifPrerequisites iface)- allParents <- forM gobjectPrereqs $ \p -> (p : ) <$> instanceTree p- let uniqueParents = nub (concat allParents)- genGObjectCasts isIU n cn_ uniqueParents- else group $ do- let cls = classConstraint name'- line $ "class ForeignPtrNewtype a => " ++ cls ++ " a"- line $ "instance (ForeignPtrNewtype o, IsDescendantOf " ++ name' ++ " o) => " ++ cls ++ " o"- line $ "type instance ParentTypes " ++ name' ++ " = '[]"+ noName name' - -- Methods- forM_ (ifMethods iface) $ \(mn, f) -> do- isFunction <- symbolFromFunction (methodSymbol f)- unless isFunction $- handleCGExc- (\e -> line ("-- XXX Could not generate method "- ++ name' ++ "::" ++ name mn ++ "\n"- ++ "-- Error was : " ++ describeCGError e))- (genMethod n mn f)+ forM_ (ifSignals iface) $ \s -> handleCGExc+ (line . (T.concat ["-- XXX Could not generate signal ", name', "::"+ , sigName s+ , "\n", "-- Error was : "] <>) . describeCGError)+ (genSignal s n) - -- And finally signals- forM_ (ifSignals iface) $ \s -> handleCGExc- (line . (concat ["-- XXX Could not generate signal ", name', "::"- , (T.unpack . sigName) s- , "\n", "-- Error was : "] ++) . describeCGError)- (genSignal s n)+ genInterfaceProperties n iface+ genInterfaceSignals n iface + isGO <- apiIsGObject n (APIInterface iface)+ if isGO+ then do+ let cn_ = fromMaybe (error "GObject derived interface without a type!") (ifTypeInit iface)+ isIU <- apiIsInitiallyUnowned n (APIInterface iface)+ gobjectPrereqs <- filterM nameIsGObject (ifPrerequisites iface)+ allParents <- forM gobjectPrereqs $ \p -> (p : ) <$> instanceTree p+ let uniqueParents = nub (concat allParents)+ genGObjectCasts isIU n cn_ uniqueParents++ else group $ do+ let cls = classConstraint name'+ exportDecl cls+ bline $ "class ForeignPtrNewtype a => " <> cls <> " a"+ bline $ "instance (ForeignPtrNewtype o, IsDescendantOf " <> name' <> " o) => " <> cls <> " o"+ let parentObjectsType = name' <> "ParentTypes"+ line $ "type instance ParentTypes " <> name' <> " = " <> parentObjectsType+ line $ "type " <> parentObjectsType <> " = '[]"++ -- Methods+ forM_ (ifMethods iface) $ \(mn, f) -> do+ isFunction <- symbolFromFunction (methodSymbol f)+ unless isFunction $+ handleCGExc+ (\e -> line ("-- XXX Could not generate method "+ <> name' <> "::" <> name mn <> "\n"+ <> "-- Error was : " <> describeCGError e))+ (genMethod n mn f)+ -- Some type libraries include spurious interface/struct methods, -- where a method Mod.Foo::func also appears as an ordinary function -- in the list of APIs. If we find a matching function, we don't@@ -424,95 +452,34 @@ genAPI n (APIObject o) = genObject n o genAPI n (APIInterface i) = genInterface n i -genPrelude :: String -> String -> CodeGen ()-genPrelude name modulePrefix = do- let mp = (modulePrefix ++)-- line "-- Generated code."- blank- line "{-# OPTIONS_GHC -fno-warn-unused-imports #-}"- blank- line "{-# LANGUAGE ForeignFunctionInterface, ConstraintKinds,"- line " TypeFamilies, MultiParamTypeClasses, KindSignatures,"- line " FlexibleInstances, UndecidableInstances, DataKinds,"- line " OverloadedStrings, NegativeLiterals, FlexibleContexts #-}"- blank- -- XXX: Generate export list.- line $ "module " ++ mp name ++ " where"- blank- -- The Prelude functions often clash with variable names or- -- functions defined in the bindings, so we only import the- -- necessary minimum into our namespace.- line "import Prelude ()"- line "import Data.GI.Base.ShortPrelude"- line "import Data.Char"- line "import Data.Int"- line "import Data.Word"- line "import qualified Data.ByteString.Char8 as B"- line "import Data.ByteString.Char8 (ByteString)"- line "import qualified Data.Map as Map"- line "import Foreign.C"- line "import Foreign.Ptr"- line "import Foreign.ForeignPtr"- line "import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)"- line "import Foreign.Storable (peek, poke, sizeOf)"- line "import Control.Applicative ((<$>))"- line "import Control.Exception (onException)"- line "import Control.Monad.IO.Class"- line "import qualified Data.Text as T"- blank- line "import Data.GI.Base.Attributes hiding (get, set)"- line "import Data.GI.Base.BasicTypes"- line "import Data.GI.Base.BasicConversions"- line "import Data.GI.Base.Closure"- line "import Data.GI.Base.GError"- line "import Data.GI.Base.GHashTable"- line "import Data.GI.Base.GParamSpec"- line "import Data.GI.Base.GVariant"- line "import Data.GI.Base.GValue"- line "import Data.GI.Base.ManagedPtr"- line "import Data.GI.Base.Overloading"- line "import Data.GI.Base.Properties hiding (new)"- line "import Data.GI.Base.Signals (SignalConnectMode(..), connectSignalFunPtr, SignalHandlerId)"- line "import Data.GI.Base.Utils"- blank--genModule :: String -> [(Name, API)] -> String -> CodeGen ()-genModule name apis modulePrefix = do- let mp = (modulePrefix ++)- name' = ucFirst name+genModule' :: M.Map Name API -> CodeGen ()+genModule' apis = do+ mapM_ (uncurry genAPI)+ -- We provide these ourselves+ $ filter ((`notElem` [ Name "GLib" "Array"+ , Name "GLib" "Error"+ , Name "GLib" "HashTable"+ , Name "GLib" "List"+ , Name "GLib" "SList"+ , Name "GLib" "Variant"+ , Name "GObject" "Value"+ , Name "GObject" "Closure"]) . fst)+ -- Some callback types are defined inside structs+ $ map fixAPIStructs+ $ M.toList+ $ apis - -- Any module depends on itself, load the information onto the state- -- of the monad. This has to be done early, so symbolFromFunction- -- above has access to it. It would probably be better to prune the- -- duplicated method/functions in advance, and get rid of- -- symbolFromFunction and this loadDependency altogether.- loadDependency name+ -- Make sure we generate a "Callbacks" module, since it is imported+ -- by other modules. It is fine if it ends up empty.+ submodule "Callbacks" $ return () +genModule :: M.Map Name API -> CodeGen ()+genModule apis = do -- Some API symbols are embedded into structures, extract these and -- inject them into the set of APIs loaded and being generated.- let embeddedAPIs = concatMap extractCallbacksInStruct apis- injectAPIs embeddedAPIs-- code <- recurse' $ mapM_ (uncurry genAPI) $- -- We provide these ourselves- filter ((`notElem` [ Name "GLib" "Array"- , Name "GLib" "Error"- , Name "GLib" "HashTable"- , Name "GLib" "List"- , Name "GLib" "SList"- , Name "GLib" "Variant"- , Name "GObject" "Value"- , Name "GObject" "Closure"]) . fst) $- -- Some callback types are defined inside structs- map fixAPIStructs $ (++ embeddedAPIs) apis-- genPrelude name' modulePrefix- deps <- S.toList <$> getDeps- forM_ deps $ \i -> when (i /= name) $ do- line $ "import qualified " ++ mp (ucFirst i) ++ " as " ++ ucFirst i- line $ "import qualified " ++ mp (ucFirst i) ++ "Attributes as "- ++ ucFirst i ++ "A"- blank-- tell code+ let embeddedAPIs = (M.fromList+ . concatMap extractCallbacksInStruct+ . M.toList) apis+ allAPIs <- getAPIs+ recurseWithAPIs (M.union allAPIs embeddedAPIs)+ (genModule' (M.union apis embeddedAPIs))
src/GI/Config.hs view
@@ -2,11 +2,12 @@ ( Config(..) ) where +import Data.Text (Text) import GI.Overrides (Overrides) data Config = Config { -- | Name of the module being generated.- modName :: Maybe String,+ modName :: Maybe Text, -- | Whether to print extra info. verbose :: Bool, -- | List of loaded overrides for the code generator.
src/GI/Constant.hs view
@@ -2,70 +2,94 @@ ( genConstant ) where -import qualified Data.Text as T+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+ import Data.Text (Text) import GI.API import GI.Code import GI.Conversions import GI.Type+import GI.Util (tshow) +-- | Data for a bidrectional pattern synonym. It is either a simple+-- one of the form "pattern Name = value :: Type" or an explicit one+-- of the form+-- > pattern Name <- (view -> value) :: Type where+-- > Name = expression value :: Type+data PatternSynonym = SimpleSynonym PSValue PSType+ | ExplicitSynonym PSView PSExpression PSValue PSType++-- Some simple types for legibility+type PSValue = Text+type PSType = Text+type PSView = Text+type PSExpression = Text++writePattern :: Text -> PatternSynonym -> CodeGen ()+writePattern name (SimpleSynonym value t) = line $+ "pattern " <> name <> " = " <> value <> " :: " <> t+writePattern name (ExplicitSynonym view expression value t) = do+ line $+ "pattern " <> name <> " <- (" <> view <> " -> " <> value <> ") :: " <> t <> " where"+ indent $ line $+ name <> " = " <> expression <> " " <> value <> " :: " <> t+ genConstant :: Name -> Constant -> CodeGen ()-genConstant (Name _ name) (Constant t value deprecated) = do- line $ "-- constant " ++ name- line $ deprecatedPragma name deprecated+genConstant (Name _ name) (Constant t value deprecated) =+ submodule "Constants" $ group $ do+ setLanguagePragmas ["PatternSynonyms", "ScopedTypeVariables",+ "ViewPatterns"]+ line $ deprecatedPragma name deprecated - handleCGExc (\e -> line $ "-- XXX: Could not generate constant: " ++ describeCGError e)- (assignValue name t value)+ handleCGExc (\e -> line $ "-- XXX: Could not generate constant: " <> describeCGError e)+ (assignValue name t value >>+ exportToplevel ("pattern " <> name)) -- | Assign to the given name the given constant value, in a way that -- can be assigned to the corresponding Haskell type.-assignValue :: String -> Type -> Text -> ExcCodeGen ()+assignValue :: Text -> Type -> Text -> ExcCodeGen ()+assignValue name t@(TBasicType TVoid) value = do+ ht <- tshow <$> haskellType t+ writePattern name (ExplicitSynonym "ptrToIntPtr" "intPtrToPtr" value ht) assignValue name t@(TBasicType b) value = do- ht <- haskellType t- line $ name ++ " :: " ++ show ht+ ht <- tshow <$> haskellType t hv <- showBasicType b value- line $ name ++ " = " ++ hv+ writePattern name (SimpleSynonym hv ht) assignValue name t@(TInterface _ _) value = do- ht <- haskellType t+ ht <- tshow <$> haskellType t api <- findAPI t case api of- Just (APIEnum _) -> do- line $ name ++ " :: " ++ show ht- line $ name ++ " = toEnum " ++ T.unpack value- Just (APIFlags _) -> do- line $ name ++ " :: " ++ show ht- line $ name ++ " = wordToGFlags " ++ T.unpack value- Just (APIStruct s) | structIsBoxed s == False -> do- line $ name ++ " :: IO " ++ show ht- line $ name ++ " = do"- indent $ do- line $ "let ptr = intPtrToPtr " ++ T.unpack value- wrapped <- convert "ptr" (fToH t TransferNothing)- line $ "return " ++ wrapped- _ -> notImplementedError $ "Don't know how to treat constants of type " ++ show t-assignValue _ t _ = notImplementedError $ "Don't know how to treat constants of type " ++ show t+ Just (APIEnum _) ->+ writePattern name (ExplicitSynonym "fromEnum" "toEnum" value ht)+ Just (APIFlags _) ->+ writePattern name (ExplicitSynonym "gflagsToWord" "wordToGFlags" value ht)+ _ -> notImplementedError $ "Don't know how to treat constants of type " <> tshow t+assignValue _ t _ = notImplementedError $ "Don't know how to treat constants of type " <> tshow t -- | Show a basic type, in a way that can be assigned to the -- corresponding Haskell type.-showBasicType :: BasicType -> Text -> ExcCodeGen String-showBasicType TInt8 i = return $ T.unpack i-showBasicType TUInt8 i = return $ T.unpack i-showBasicType TInt16 i = return $ T.unpack i-showBasicType TUInt16 i = return $ T.unpack i-showBasicType TInt32 i = return $ T.unpack i-showBasicType TUInt32 i = return $ T.unpack i-showBasicType TInt64 i = return $ T.unpack i-showBasicType TUInt64 i = return $ T.unpack i+showBasicType :: BasicType -> Text -> ExcCodeGen Text+showBasicType TInt8 i = return i+showBasicType TUInt8 i = return i+showBasicType TInt16 i = return i+showBasicType TUInt16 i = return i+showBasicType TInt32 i = return i+showBasicType TUInt32 i = return i+showBasicType TInt64 i = return i+showBasicType TUInt64 i = return i showBasicType TBoolean "0" = return "False" showBasicType TBoolean "false" = return "False" showBasicType TBoolean "1" = return "True" showBasicType TBoolean "true" = return "True"-showBasicType TBoolean b = notImplementedError $ "Could not parse boolean \"" ++ T.unpack b ++ "\""-showBasicType TFloat f = return $ T.unpack f-showBasicType TDouble d = return $ T.unpack d-showBasicType TUTF8 s = return $ show s-showBasicType TFileName fn = return $ show fn-showBasicType TUniChar c = return $ "'" ++ T.unpack c ++ "'"-showBasicType TVoid ptr = return $ "intPtrToPtr " ++ T.unpack ptr-showBasicType TGType gtype = return $ "GType " ++ T.unpack gtype+showBasicType TBoolean b = notImplementedError $ "Could not parse boolean \"" <> b <> "\""+showBasicType TFloat f = return f+showBasicType TDouble d = return d+showBasicType TUTF8 s = return . tshow $ s+showBasicType TFileName fn = return . tshow $ fn+showBasicType TUniChar c = return $ "'" <> c <> "'"+showBasicType TGType gtype = return $ "GType " <> gtype+-- We take care of this one separately above+showBasicType TVoid _ = notImplementedError $ "Cannot directly show a pointer"
src/GI/Conversions.hs view
@@ -33,9 +33,9 @@ #endif import Control.Monad (when) import Control.Monad.Free (Free(..), liftF)-import Data.List (intercalate) import Data.Typeable (TypeRep, tyConName, typeRepTyCon, typeOf) import Data.Int+import Data.Text (Text) import qualified Data.Text as T import Data.Word import GHC.Exts (IsString(..))@@ -51,10 +51,10 @@ -- either (by default) a pure function (indicated by the P -- constructor) or a function returning values on a monad (M -- constructor). 'Id' denotes the identity function.-data Constructor = P String | M String | Id+data Constructor = P Text | M Text | Id deriving (Eq,Show) instance IsString Constructor where- fromString = P+ fromString = P . T.pack data FExpr next = Apply Constructor next | MapC Map Constructor next@@ -68,13 +68,13 @@ deriving (Show) -- Naming for the maps.-mapName :: Map -> String+mapName :: Map -> Text mapName Map = "map" mapName MapFirst = "mapFirst" mapName MapSecond = "mapSecond" -- Naming for the monadic versions of the maps that we use-monadicMapName :: Map -> String+monadicMapName :: Map -> Text monadicMapName Map = "mapM" monadicMapName MapFirst = "mapFirstA" monadicMapName MapSecond = "mapSecondA"@@ -94,53 +94,53 @@ literal :: Constructor -> Converter literal f = liftF $ Literal f () -genConversion :: String -> Converter -> CodeGen String+genConversion :: Text -> Converter -> CodeGen Text genConversion l (Pure ()) = return l genConversion l (Free k) = do let l' = prime l case k of Apply (P f) next ->- do line $ "let " ++ l' ++ " = " ++ f ++ " " ++ l+ do line $ "let " <> l' <> " = " <> f <> " " <> l genConversion l' next Apply (M f) next ->- do line $ l' ++ " <- " ++ f ++ " " ++ l+ do line $ l' <> " <- " <> f <> " " <> l genConversion l' next Apply Id next -> genConversion l next MapC m (P f) next ->- do line $ "let " ++ l' ++ " = " ++ mapName m ++ " " ++ f ++ " " ++ l+ do line $ "let " <> l' <> " = " <> mapName m <> " " <> f <> " " <> l genConversion l' next MapC m (M f) next ->- do line $ l' ++ " <- " ++ monadicMapName m ++ " " ++ f ++ " " ++ l+ do line $ l' <> " <- " <> monadicMapName m <> " " <> f <> " " <> l genConversion l' next MapC _ Id next -> genConversion l next Literal (P f) next ->- do line $ "let " ++ l ++ " = " ++ f+ do line $ "let " <> l <> " = " <> f genConversion l next Literal (M f) next ->- do line $ l ++ " <- " ++ f+ do line $ l <> " <- " <> f genConversion l next Literal Id next -> genConversion l next -- Given an array, together with its type, return the code for reading -- its length.-computeArrayLength :: String -> Type -> ExcCodeGen String+computeArrayLength :: Text -> Type -> ExcCodeGen Text computeArrayLength array (TCArray _ _ _ t) = do reader <- findReader- return $ "fromIntegral $ " ++ reader ++ " " ++ array+ return $ "fromIntegral $ " <> reader <> " " <> array where findReader = case t of TBasicType TUInt8 -> return "B.length" TBasicType _ -> return "length" TInterface _ _ -> return "length" TCArray{} -> return "length" _ -> notImplementedError $- "Don't know how to compute length of " ++ show t+ "Don't know how to compute length of " <> tshow t computeArrayLength _ t = notImplementedError $ "computeArrayLength called on non-CArray type "- ++ show t+ <> tshow t -convert :: String -> BaseCodeGen e Converter -> BaseCodeGen e String+convert :: Text -> BaseCodeGen e Converter -> BaseCodeGen e Text convert l c = do c' <- c genConversion l c'@@ -247,8 +247,8 @@ | TCArray False _ _ (TBasicType _) <- t = return $ M "packStorableArray" | TCArray{} <- t = notImplementedError $- "Don't know how to pack C array of type " ++ show t- | otherwise = case (show hType, show fType) of+ "Don't know how to pack C array of type " <> tshow t+ | otherwise = case (tshow hType, tshow fType) of ("T.Text", "CString") -> return $ M "textToCString" ("[Char]", "CString") -> return $ M "stringToCString" ("Char", "CInt") -> return "(fromIntegral . ord)"@@ -258,10 +258,10 @@ ("GType", "CGType") -> return "gtypeToCGType" _ -> notImplementedError $ "Don't know how to convert "- ++ show hType ++ " into "- ++ show fType ++ ".\n"- ++ "Internal type: "- ++ show t+ <> tshow hType <> " into "+ <> tshow fType <> ".\n"+ <> "Internal type: "+ <> tshow t getForeignConstructor :: Type -> Transfer -> ExcCodeGen Constructor getForeignConstructor t transfer = do@@ -270,7 +270,7 @@ fType <- foreignType t hToF' t a hType fType transfer -hToF_PackedType :: Type -> String -> Transfer -> ExcCodeGen Converter+hToF_PackedType :: Type -> Text -> Transfer -> ExcCodeGen Converter hToF_PackedType t packer transfer = do innerConstructor <- getForeignConstructor t transfer return $ do@@ -279,22 +279,22 @@ -- | Try to find the `hash` and `equal` functions appropriate for the -- given type, when used as a key in a GHashTable.-hashTableKeyMappings :: Type -> ExcCodeGen (String, String)+hashTableKeyMappings :: Type -> ExcCodeGen (Text, Text) hashTableKeyMappings (TBasicType TVoid) = return ("gDirectHash", "gDirectEqual") hashTableKeyMappings (TBasicType TUTF8) = return ("gStrHash", "gStrEqual") hashTableKeyMappings t =- notImplementedError $ "GHashTable key of type " ++ show t ++ " unsupported."+ notImplementedError $ "GHashTable key of type " <> tshow t <> " unsupported." -- | `GHashTable` tries to fit every type into a pointer, the -- following function tries to find the appropriate -- (destroy,packer,unpacker) for the given type.-hashTablePtrPackers :: Type -> ExcCodeGen (String, String, String)+hashTablePtrPackers :: Type -> ExcCodeGen (Text, Text, Text) hashTablePtrPackers (TBasicType TVoid) = return ("Nothing", "ptrPackPtr", "ptrUnpackPtr") hashTablePtrPackers (TBasicType TUTF8) = return ("(Just ptr_to_g_free)", "cstringPackPtr", "cstringUnpackPtr") hashTablePtrPackers t =- notImplementedError $ "GHashTable element of type " ++ show t ++ " unsupported."+ notImplementedError $ "GHashTable element of type " <> tshow t <> " unsupported." hToF_PackGHashTable :: Type -> Type -> ExcCodeGen Converter hToF_PackGHashTable keys elems = do@@ -311,8 +311,8 @@ mapSecond elemsConstructor mapFirst (P keyPack) mapSecond (P elemPack)- apply (M (intercalate " " ["packGHashTable", keyHash, keyEqual,- keyDestroy, elemDestroy]))+ apply (M (T.intercalate " " ["packGHashTable", keyHash, keyEqual,+ keyDestroy, elemDestroy])) hToF :: Type -> Transfer -> ExcCodeGen Converter hToF (TGList t) transfer = hToF_PackedType t "packGList" transfer@@ -326,7 +326,7 @@ let packer = if zt then "packZeroTerminated" else "pack"- hToF_PackedType t (packer ++ "PtrArray") transfer+ hToF_PackedType t (packer <> "PtrArray") transfer hToF (TCArray zt _ _ t@(TInterface _ _)) transfer = do isScalar <- getIsScalar t@@ -334,7 +334,7 @@ then "packZeroTerminated" else "pack" if isScalar- then hToF_PackedType t (packer ++ "StorableArray") transfer+ then hToF_PackedType t (packer <> "StorableArray") transfer else do api <- findAPI t let size = case api of@@ -342,8 +342,8 @@ Just (APIUnion u) -> unionSize u _ -> 0 if size == 0 || zt- then hToF_PackedType t (packer ++ "PtrArray") transfer- else hToF_PackedType t (packer ++ "BlockArray " ++ show size) transfer+ then hToF_PackedType t (packer <> "PtrArray") transfer+ else hToF_PackedType t (packer <> "BlockArray " <> tshow size) transfer hToF t transfer = do a <- findAPI t@@ -352,26 +352,26 @@ constructor <- hToF' t a hType fType transfer return $ apply constructor -boxedForeignPtr :: String -> Transfer -> CodeGen Constructor+boxedForeignPtr :: Text -> Transfer -> CodeGen Constructor boxedForeignPtr constructor transfer = return $ case transfer of- TransferEverything -> M $ parenthesize $ "wrapBoxed " ++ constructor- _ -> M $ parenthesize $ "newBoxed " ++ constructor+ TransferEverything -> M $ parenthesize $ "wrapBoxed " <> constructor+ _ -> M $ parenthesize $ "newBoxed " <> constructor suForeignPtr :: Bool -> Int -> TypeRep -> Transfer -> CodeGen Constructor suForeignPtr isBoxed size hType transfer = do- let constructor = tyConName $ typeRepTyCon hType+ let constructor = T.pack . tyConName . typeRepTyCon $ hType if isBoxed then boxedForeignPtr constructor transfer else case size of 0 -> do line "-- XXX Wrapping a foreign struct/union with no known destructor, leak?" return $ M $ parenthesize $- "\\x -> " ++ constructor ++ " <$> newForeignPtr_ x"+ "\\x -> " <> constructor <> " <$> newForeignPtr_ x" n -> return $ M $ parenthesize $ case transfer of- TransferEverything -> "wrapPtr " ++ constructor- _ -> "newPtr " ++ show n ++ " " ++ constructor+ TransferEverything -> "wrapPtr " <> constructor+ _ -> "newPtr " <> tshow n <> " " <> constructor structForeignPtr :: Struct -> TypeRep -> Transfer -> CodeGen Constructor structForeignPtr s =@@ -383,16 +383,16 @@ fObjectToH :: Type -> TypeRep -> Transfer -> ExcCodeGen Constructor fObjectToH t hType transfer = do- let constructor = tyConName $ typeRepTyCon hType+ let constructor = T.pack . tyConName . typeRepTyCon $ hType isGO <- isGObject t case transfer of TransferEverything -> if isGO- then return $ M $ parenthesize $ "wrapObject " ++ constructor+ then return $ M $ parenthesize $ "wrapObject " <> constructor else badIntroError "Got a transfer of something not a GObject" _ -> if isGO- then return $ M $ parenthesize $ "newObject " ++ constructor+ then return $ M $ parenthesize $ "newObject " <> constructor else badIntroError "Wrapping not a GObject with no copy..." fCallbackToH :: Callback -> TypeRep -> Transfer -> ExcCodeGen Constructor@@ -444,10 +444,10 @@ | TCArray True _ _ (TBasicType _) <- t = return $ M "unpackZeroTerminatedStorableArray" | TCArray{} <- t = notImplementedError $- "Don't know how to unpack C array of type " ++ show t+ "Don't know how to unpack C array of type " <> tshow t | TByteArray <- t = return $ M "unpackGByteArray" | TGHash _ _ <- t = notImplementedError "Foreign Hashes not supported yet"- | otherwise = case (show fType, show hType) of+ | otherwise = case (tshow fType, tshow hType) of ("CString", "T.Text") -> return $ M "cstringToText" ("CString", "[Char]") -> return $ M "cstringToString" ("CInt", "Char") -> return "(chr . fromIntegral)"@@ -457,10 +457,10 @@ ("CGType", "GType") -> return "GType" _ -> notImplementedError $ "Don't know how to convert "- ++ show fType ++ " into "- ++ show hType ++ ".\n"- ++ "Internal type: "- ++ show t+ <> tshow fType <> " into "+ <> tshow hType <> ".\n"+ <> "Internal type: "+ <> tshow t getHaskellConstructor :: Type -> Transfer -> ExcCodeGen Constructor getHaskellConstructor t transfer = do@@ -469,7 +469,7 @@ fType <- foreignType t fToH' t a hType fType transfer -fToH_PackedType :: Type -> String -> Transfer -> ExcCodeGen Converter+fToH_PackedType :: Type -> Text -> Transfer -> ExcCodeGen Converter fToH_PackedType t unpacker transfer = do innerConstructor <- getHaskellConstructor t transfer return $ do@@ -514,27 +514,27 @@ constructor <- fToH' t a hType fType transfer return $ apply constructor -unpackCArray :: String -> Type -> Transfer -> ExcCodeGen Converter+unpackCArray :: Text -> Type -> Transfer -> ExcCodeGen Converter unpackCArray length (TCArray False _ _ t) transfer = case t of TBasicType TUTF8 -> return $ apply $ M $ parenthesize $- "unpackUTF8CArrayWithLength " ++ length+ "unpackUTF8CArrayWithLength " <> length TBasicType TFileName -> return $ apply $ M $ parenthesize $- "unpackFileNameArrayWithLength " ++ length+ "unpackFileNameArrayWithLength " <> length TBasicType TUInt8 -> return $ apply $ M $ parenthesize $- "unpackByteStringWithLength " ++ length+ "unpackByteStringWithLength " <> length TBasicType TVoid -> return $ apply $ M $ parenthesize $- "unpackPtrArrayWithLength " ++ length+ "unpackPtrArrayWithLength " <> length TBasicType TBoolean -> return $ apply $ M $ parenthesize $- "unpackMapStorableArrayWithLength (/= 0) " ++ length+ "unpackMapStorableArrayWithLength (/= 0) " <> length TBasicType TGType -> return $ apply $ M $ parenthesize $- "unpackMapStorableArrayWithLength GType " ++ length+ "unpackMapStorableArrayWithLength GType " <> length TBasicType TFloat -> return $ apply $ M $ parenthesize $- "unpackMapStorableArrayWithLength realToFrac " ++ length+ "unpackMapStorableArrayWithLength realToFrac " <> length TBasicType TDouble -> return $ apply $ M $ parenthesize $- "unpackMapStorableArrayWithLength realToFrac " ++ length+ "unpackMapStorableArrayWithLength realToFrac " <> length TBasicType _ -> return $ apply $ M $ parenthesize $- "unpackStorableArrayWithLength " ++ length+ "unpackStorableArrayWithLength " <> length TInterface _ _ -> do a <- findAPI t isScalar <- getIsScalar t@@ -547,40 +547,41 @@ _ -> (False, 0) let unpacker | isScalar = "unpackStorableArrayWithLength" | (size == 0) = "unpackPtrArrayWithLength"- | boxed = "unpackBoxedArrayWithLength " ++ show size- | otherwise = "unpackBlockArrayWithLength " ++ show size+ | boxed = "unpackBoxedArrayWithLength " <> tshow size+ | otherwise = "unpackBlockArrayWithLength " <> tshow size return $ do- apply $ M $ parenthesize $ unpacker ++ " " ++ length+ apply $ M $ parenthesize $ unpacker <> " " <> length mapC innerConstructor _ -> notImplementedError $- "unpackCArray : Don't know how to unpack C Array of type " ++ show t+ "unpackCArray : Don't know how to unpack C Array of type " <> tshow t unpackCArray _ _ _ = notImplementedError "unpackCArray : unexpected array type." -- Given a type find the typeclasses the type belongs to, and return -- the representation of the type in the function signature and the -- list of typeclass constraints for the type.-argumentType :: [Char] -> Type -> CodeGen ([Char], String, [String])+argumentType :: [Char] -> Type -> CodeGen ([Char], Text, [Text]) argumentType [] _ = error "out of letters" argumentType letters (TGList a) = do (ls, name, constraints) <- argumentType letters a- return (ls, "[" ++ name ++ "]", constraints)+ return (ls, "[" <> name <> "]", constraints) argumentType letters (TGSList a) = do (ls, name, constraints) <- argumentType letters a- return (ls, "[" ++ name ++ "]", constraints)+ return (ls, "[" <> name <> "]", constraints) argumentType letters@(l:ls) t = do api <- findAPI t- s <- show <$> haskellType t+ s <- tshow <$> haskellType t case api of Just (APIInterface _) -> do- let constraints = [classConstraint s ++ " " ++ [l]]- return (ls, [l], constraints)+ let constraints = [classConstraint s <> " " <> T.singleton l]+ return (ls, T.singleton l, constraints) -- Instead of restricting to the actual class, -- we allow for any object descending from it. Just (APIObject _) -> do isGO <- isGObject t if isGO- then return (ls, [l], [classConstraint s ++ " " ++ [l]])+ then return (ls, T.singleton l,+ [classConstraint s <> " " <> T.singleton l]) else return (letters, s, []) _ -> return (letters, s, []) @@ -638,7 +639,7 @@ haskellType t@(TInterface ns n) = do prefix <- qualify ns api <- findAPI t- let tname = T.pack (prefix ++ n) `con` []+ let tname = (prefix <> n) `con` [] return $ case api of Just (APIFlags _) -> "[]" `con` [tname] _ -> tname@@ -699,8 +700,8 @@ prefix <- qualify ns return $ case api of Just (APICallback _) ->- funptr $ T.pack (prefix ++ n ++ "C") `con` []- _ -> ptr $ T.pack (prefix ++ n) `con` []+ funptr $ (prefix <> n <> "C") `con` []+ _ -> ptr $ (prefix <> n) `con` [] getIsScalar :: Type -> CodeGen Bool getIsScalar t = do@@ -747,16 +748,16 @@ -- If the given type maps to a list in Haskell, return the type of the -- elements, and the function that maps over them.-elementTypeAndMap :: Type -> String -> Maybe (Type, String)+elementTypeAndMap :: Type -> Text -> Maybe (Type, Text) -- Passed along as a raw pointer. elementTypeAndMap (TCArray False (-1) (-1) _) _ = Nothing -- ByteString elementTypeAndMap (TCArray _ _ _ (TBasicType TUInt8)) _ = Nothing elementTypeAndMap (TCArray True _ _ t) _ = Just (t, "mapZeroTerminatedCArray") elementTypeAndMap (TCArray False (-1) _ t) len =- Just (t, parenthesize $ "mapCArrayWithLength " ++ len)+ Just (t, parenthesize $ "mapCArrayWithLength " <> len) elementTypeAndMap (TCArray False fixed _ t) _ =- Just (t, parenthesize $ "mapCArrayWithLength " ++ show fixed)+ Just (t, parenthesize $ "mapCArrayWithLength " <> tshow fixed) elementTypeAndMap (TGArray t) _ = Just (t, "mapGArray") elementTypeAndMap (TPtrArray t) _ = Just (t, "mapPtrArray") elementTypeAndMap (TGList t) _ = Just (t, "mapGList")@@ -769,5 +770,5 @@ elementType t = fst <$> elementTypeAndMap t undefined -- Return just the map.-elementMap :: Type -> String -> Maybe String+elementMap :: Type -> Text -> Maybe Text elementMap t len = snd <$> elementTypeAndMap t len
src/GI/GIR/BasicTypes.hs view
@@ -8,7 +8,7 @@ import Data.Text (Text) -- | Name for a symbol in the GIR file.-data Name = Name { namespace :: String, name :: String }+data Name = Name { namespace :: Text, name :: Text } deriving (Eq, Ord, Show) -- | Transfer mode for an argument or property.
src/GI/GIR/Deprecation.hs view
@@ -4,6 +4,7 @@ , queryDeprecated ) where +import Data.Monoid ((<>)) import qualified Data.Map as M import qualified Data.Text as T import Data.Text (Text)@@ -19,16 +20,16 @@ -- | Encode the given `DeprecationInfo` for the given symbol as a -- deprecation pragma.-deprecatedPragma :: String -> Maybe DeprecationInfo -> String+deprecatedPragma :: Text -> Maybe DeprecationInfo -> Text deprecatedPragma _ Nothing = ""-deprecatedPragma name (Just info) = "{-# DEPRECATED " ++ name ++ " " ++- show (note ++ reason) ++ "#-}"+deprecatedPragma name (Just info) = "{-# DEPRECATED " <> name <> " " <>+ (T.pack . show) (note <> reason) <> "#-}" where reason = case deprecationMessage info of Nothing -> []- Just msg -> (lines . T.unpack) msg+ Just msg -> T.lines msg note = case deprecatedSinceVersion info of Nothing -> []- Just v -> ["(Since version " ++ T.unpack v ++ ")"]+ Just v -> ["(Since version " <> v <> ")"] -- | Parse the deprecation information for the given element of the GIR file. queryDeprecated :: Element -> Maybe DeprecationInfo
+ src/GI/GIR/Documentation.hs view
@@ -0,0 +1,20 @@+-- | Parsing of documentation nodes.+module GI.GIR.Documentation+ ( Documentation(..)+ , queryDocumentation+ ) where++import Data.Text (Text)+import Text.XML (Element)++import GI.GIR.XMLUtils (firstChildWithLocalName, getElementContent)++-- | Documentation for a given element.+data Documentation = Documentation {+ docText :: Text+ } deriving (Show, Eq)++-- | Parse the documentation node for the given element of the GIR file.+queryDocumentation :: Element -> Maybe Documentation+queryDocumentation element = fmap Documentation+ (firstChildWithLocalName "doc" element >>= getElementContent)
src/GI/GIR/Function.hs view
@@ -4,7 +4,6 @@ ) where import Data.Text (Text)-import qualified Data.Text as T import GI.GIR.Callable (Callable(..), parseCallable) import GI.GIR.Parser@@ -20,7 +19,7 @@ name <- parseName shadows <- queryAttr "shadows" let exposedName = case shadows of- Just n -> name {name = T.unpack n}+ Just n -> name {name = n} Nothing -> name callable <- parseCallable symbol <- getAttrWithNamespace CGIRNS "identifier"
src/GI/GIR/Method.hs view
@@ -5,7 +5,6 @@ ) where import Data.Text (Text)-import qualified Data.Text as T import GI.GIR.Callable (Callable(..), parseCallable) import GI.GIR.Parser@@ -28,7 +27,7 @@ name <- parseName shadows <- queryAttr "shadows" let exposedName = case shadows of- Just n -> name {name = T.unpack n}+ Just n -> name {name = n} Nothing -> name callable <- parseCallable symbol <- getAttrWithNamespace CGIRNS "identifier"
src/GI/GIR/Object.hs view
@@ -17,6 +17,7 @@ objTypeName :: Text, objInterfaces :: [Name], objDeprecated :: Maybe DeprecationInfo,+ objDocumentation :: Maybe Documentation, objMethods :: [(Name, Method)], objProperties :: [Property], objSignals :: [Signal]@@ -26,6 +27,7 @@ parseObject = do name <- parseName deprecated <- parseDeprecation+ doc <- parseDocumentation methods <- parseChildrenWithLocalName "method" (parseMethod OrdinaryMethod) constructors <- parseChildrenWithLocalName "constructor" (parseMethod Constructor) functions <- parseChildrenWithLocalName "function" (parseMethod MemberFunction)@@ -42,6 +44,7 @@ , objTypeName = typeName , objInterfaces = interfaces , objDeprecated = deprecated+ , objDocumentation = doc , objMethods = constructors ++ methods ++ functions , objProperties = props , objSignals = signals
src/GI/GIR/Parser.hs view
@@ -8,6 +8,7 @@ , parseName , parseDeprecation+ , parseDocumentation , parseIntegral , parseBool , parseChildrenWithLocalName@@ -29,6 +30,7 @@ , Element , GIRXMLNamespace(..) , DeprecationInfo+ , Documentation ) where #if !MIN_VERSION_base(4,8,0)@@ -51,6 +53,7 @@ import GI.GIR.BasicTypes (Name(..), Alias(..)) import GI.GIR.Deprecation (DeprecationInfo, queryDeprecated)+import GI.GIR.Documentation (Documentation, queryDocumentation) import GI.GIR.XMLUtils (localName, GIRXMLNamespace(..), childElemsWithLocalName, childElemsWithNSName, lookupAttr, lookupAttrWithNamespace)@@ -92,7 +95,7 @@ nameInCurrentNS :: Text -> Parser Name nameInCurrentNS n = do ctx <- ask- return $ Name (T.unpack (ctxNamespace ctx)) (T.unpack n)+ return $ Name (ctxNamespace ctx) n -- | Return the current namespace. currentNamespace :: Parser Text@@ -106,9 +109,9 @@ case M.lookup (Alias (ns, n)) (knownAliases ctx) of -- The resolved type may be an alias itself, like for -- Gtk.Allocation -> Gdk.Rectangle -> cairo.RectangleInt- Just (TInterface ns n) -> resolveQualifiedTypeName (T.pack ns) (T.pack n)+ Just (TInterface ns n) -> resolveQualifiedTypeName ns n Just t -> return t- Nothing -> return $ TInterface (T.unpack ns) (T.unpack n)+ Nothing -> return $ TInterface ns n -- | Return the value of an attribute for the given element. If the -- attribute is not present this throws an error.@@ -155,7 +158,7 @@ -- namespace, and otherwise we simply parse it. qualifyName :: Text -> Parser Name qualifyName n = case T.split (== '.') n of- [ns, name] -> return $ Name (T.unpack ns) (T.unpack name)+ [ns, name] -> return $ Name ns name [name] -> nameInCurrentNS name _ -> parseError "Could not understand name" @@ -168,6 +171,12 @@ parseDeprecation = do ctx <- ask return $ queryDeprecated (currentElement ctx)++-- | Parse the documentation text, if present.+parseDocumentation :: Parser (Maybe Documentation)+parseDocumentation = do+ ctx <- ask+ return $ queryDocumentation (currentElement ctx) -- | Parse a signed integral number. parseIntegral :: Integral a => Text -> Parser a
src/GI/GIR/Struct.hs view
@@ -19,13 +19,15 @@ structIsDisguised :: Bool, structFields :: [Field], structMethods :: [(Name, Method)],- structDeprecated :: Maybe DeprecationInfo }+ structDeprecated :: Maybe DeprecationInfo,+ structDocumentation :: Maybe Documentation } deriving Show parseStruct :: Parser (Name, Struct) parseStruct = do name <- parseName deprecated <- parseDeprecation+ doc <- parseDocumentation structFor <- queryAttrWithNamespace GLibGIRNS "is-gtype-struct-for" >>= \case Just t -> (fmap Just . qualifyName) t Nothing -> return Nothing@@ -44,4 +46,5 @@ , structFields = fields , structMethods = constructors ++ methods , structDeprecated = deprecated+ , structDocumentation = doc })
src/GI/Inheritance.hs view
@@ -15,7 +15,8 @@ import Data.Text (Text) import GI.API-import GI.Code (findAPIByName, CodeGen, line)+import GI.Code (findAPIByName, CodeGen, line, (<>))+import GI.Util (tshow) -- | Find the parent of a given object when building the -- instanceTree. For the purposes of the binding we do not need to@@ -108,8 +109,8 @@ | (p == prop) -> return m -- Duplicated, but isomorphic property | otherwise -> do line "--- XXX Duplicated object with different types:"- line $ " --- " ++ show n ++ " -> " ++ show p- line $ " --- " ++ show name ++ " -> " ++ show prop+ line $ " --- " <> tshow n <> " -> " <> tshow p+ line $ " --- " <> tshow name <> " -> " <> tshow prop -- Tainted return $ M.insert (iName prop) (True, n, p) m Nothing -> return $ M.insert (iName prop) (False, name, prop) m
src/GI/OverloadedSignals.hs view
@@ -1,5 +1,6 @@ module GI.OverloadedSignals- ( genSignalInstances+ ( genObjectSignals+ , genInterfaceSignals , genOverloadedSignalConnectors ) where @@ -7,11 +8,9 @@ import Control.Applicative ((<$>)) #endif import Control.Monad (forM_, when)-import Control.Monad.Writer (tell) import Data.Text (Text) import qualified Data.Text as T -import Data.List (intercalate) import qualified Data.Set as S import GI.API@@ -19,13 +18,13 @@ import GI.Inheritance (fullObjectSignalList, fullInterfaceSignalList) import GI.GObject (apiIsGObject) import GI.Signal (signalHaskellName)-import GI.SymbolNaming (ucFirst, upperName)-import GI.Util (padTo)+import GI.SymbolNaming (upperName)+import GI.Util (padTo, ucFirst) -- A list of distinct signal names for all GObjects appearing in the -- given list of APIs.-findSignalNames :: [(Name, API)] -> CodeGen [String]-findSignalNames apis = (map T.unpack . S.toList) <$> go apis S.empty+findSignalNames :: [(Name, API)] -> CodeGen [Text]+findSignalNames apis = S.toList <$> go apis S.empty where go :: [(Name, API)] -> S.Set Text -> CodeGen (S.Set Text) go [] set = return set@@ -41,14 +40,11 @@ insertSignals props set = foldr (S.insert . sigName) set props -- | Generate the overloaded signal connectors: "Clicked", "ActivateLink", ...-genOverloadedSignalConnectors :: [(Name, API)] -> String -> CodeGen ()-genOverloadedSignalConnectors allAPIs modulePrefix = do- line "-- Generated code."- blank- line "{-# LANGUAGE DataKinds, GADTs, KindSignatures, FlexibleInstances #-}"- blank- line $ "module " ++ modulePrefix ++ "Signals where"- blank+genOverloadedSignalConnectors :: [(Name, API)] -> CodeGen ()+genOverloadedSignalConnectors allAPIs = do+ setLanguagePragmas ["DataKinds", "GADTs", "KindSignatures", "FlexibleInstances"]+ setModuleFlags [ImplicitPrelude, NoTypesImport, NoCallbacksImport]+ line "import GHC.TypeLits" line "import GHC.Exts (Constraint)" blank@@ -58,31 +54,33 @@ line "data SignalProxy (a :: Symbol) (b :: Symbol) (c :: * -> Constraint) where" indent $ do signalNames <- findSignalNames allAPIs- let maxLength = maximum $ map (length . signalHaskellName) signalNames+ let maxLength = maximum $ map (T.length . signalHaskellName) signalNames forM_ signalNames $ \sn ->- line $ padTo (maxLength + 1) (ucFirst (signalHaskellName sn)) ++- ":: SignalProxy \"" ++ sn ++ "\" \"\" NoConstraint"+ line $ padTo (maxLength + 1) (ucFirst (signalHaskellName sn)) <>+ ":: SignalProxy \"" <> sn <> "\" \"\" NoConstraint"+ exportToplevel "SignalProxy(..)" -- | Qualified name for the "(sigName, info)" tag for a given signal.-signalInfoName :: Name -> Signal -> CodeGen String+signalInfoName :: Name -> Signal -> CodeGen Text signalInfoName n signal = do n' <- upperName n- return $ n' ++ (ucFirst . signalHaskellName . T.unpack . sigName) signal- ++ "SignalInfo"+ return $ n' <> (ucFirst . signalHaskellName . sigName) signal+ <> "SignalInfo" -- | Generate the given signal instance for the given API object. genInstance :: Name -> Signal -> CodeGen () genInstance owner signal = group $ do name <- upperName owner- let sn = (ucFirst . signalHaskellName . T.unpack . sigName) signal+ let sn = (ucFirst . signalHaskellName . sigName) signal si <- signalInfoName owner signal- line $ "data " ++ si- line $ "instance SignalInfo " ++ si ++ " where"+ bline $ "data " <> si+ line $ "instance SignalInfo " <> si <> " where" indent $ do- let signalConnectorName = name ++ sn- cbHaskellType = signalConnectorName ++ "Callback"- line $ "type HaskellCallbackType " ++ si ++ " = " ++ cbHaskellType- line $ "connectSignal _ = " ++ "connect" ++ name ++ sn+ let signalConnectorName = name <> sn+ cbHaskellType = signalConnectorName <> "Callback"+ line $ "type HaskellCallbackType " <> si <> " = " <> cbHaskellType+ line $ "connectSignal _ = " <> "connect" <> name <> sn+ exportSignal sn si -- | Signal instances for (GObject-derived) objects. genObjectSignals :: Name -> Object -> CodeGen ()@@ -94,14 +92,17 @@ infos <- fullObjectSignalList n o >>= mapM (\(owner, signal) -> do si <- signalInfoName owner signal- return $ "'(\"" ++ (T.unpack . sigName) signal- ++ "\", " ++ si ++ ")")+ return $ "'(\"" <> sigName signal+ <> "\", " <> si <> ")") -- The "notify::[property]" signal is a generic signal used for -- connecting to property notifications.- let allSignals = infos +++ let allSignals = infos <> ["'(\"notify::[property]\", GObjectNotifySignalInfo)"]- group . line $ "type instance SignalList " ++ name ++- " = '[ " ++ intercalate ", " allSignals ++ "]"+ group $ do+ let signalListType = name <> "SignalList"+ line $ "type instance SignalList " <> name <> " = " <> signalListType+ line $ "type " <> signalListType <> " = ('[ "+ <> T.intercalate ", " allSignals <> "] :: [(Symbol, *)])" -- | Signal instances for interfaces. genInterfaceSignals :: Name -> Interface -> CodeGen ()@@ -111,61 +112,17 @@ infos <- fullInterfaceSignalList n iface >>= mapM (\(owner, signal) -> do si <- signalInfoName owner signal- return $ "'(\"" ++ T.unpack (sigName signal)- ++ "\", " ++ si ++ ")")+ return $ "'(\"" <> sigName signal+ <> "\", " <> si <> ")") isGO <- apiIsGObject n (APIInterface iface) -- The "notify::[property]" signal is a generic signal used for -- connecting to property notifications of a GObject. let allSignals = if isGO- then infos ++ ["'(\"notify::[property]\", GObjectNotifySignalInfo)"]+ then infos <> ["'(\"notify::[property]\", GObjectNotifySignalInfo)"] else infos- group . line $ "type instance SignalList " ++ name ++- " = '[ " ++ intercalate ", " allSignals ++ "]"---- | Generate HasSignal instances for a given API element.-genSignals :: (Name, API) -> CodeGen ()-genSignals (n, APIObject o) = genObjectSignals n o-genSignals (n, APIInterface i) = genInterfaceSignals n i-genSignals _ = return ()---- | Generate the signal information instances, so the generic overloaded--- signal connectors are available.-genSignalInstances :: String -> [(Name, API)] -> String -> CodeGen ()-genSignalInstances name apis modulePrefix = do- let mp = (modulePrefix ++)- nm = ucFirst name-- code <- recurse' $ forM_ apis genSignals-- line "-- Generated code."- blank-- -- Providing orphan instances is the whole point of these modules,- -- tell GHC that this is fine.- line "{-# OPTIONS_GHC -fno-warn-orphans #-}"- blank- line "{-# LANGUAGE DataKinds, FlexibleInstances,"- line " TypeFamilies, MultiParamTypeClasses,"- line " TypeOperators #-}"- blank-- line $ "module " ++ mp nm ++ "Signals where"- blank-- line "import Data.GI.Base.Properties (GObjectNotifySignalInfo)"- line "import Data.GI.Base.Signals"- line "import Data.GI.Base.Overloading"- blank-- -- Import dependencies, including instances for their overloaded- -- signals, so they are implicitly reexported and they do not need- -- to be included explicitly from client code.- deps <- S.toList <$> getDeps- forM_ deps $ \i -> when (i /= name) $- line $ "import qualified " ++ mp (ucFirst i) ++ "Signals as " ++ ucFirst i-- line $ "import " ++ modulePrefix ++ nm- blank-- tell code+ group $ do+ let signalListType = name <> "SignalList"+ line $ "type instance SignalList " <> name <> " = " <> signalListType+ line $ "type " <> signalListType <> " = ('[ "+ <> T.intercalate ", " allSignals <> "] :: [(Symbol, *)])"
src/GI/Overrides.hs view
@@ -9,7 +9,7 @@ import Control.Monad.State import Control.Monad.Writer -import Data.Maybe (fromMaybe, isJust)+import Data.Maybe (isJust) import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text as T@@ -18,9 +18,6 @@ import GI.API data Overrides = Overrides {- -- | Prefix for constants in a given namespace, if not given the- -- "_" string will be used.- constantPrefix :: M.Map String String, -- | Ignored elements of a given API. ignoredElems :: M.Map Name (S.Set Text), -- | Ignored APIs (all elements in this API will just be discarded).@@ -32,13 +29,12 @@ -- | Version number for the generated .cabal package. cabalPkgVersion :: Maybe Text, -- | Prefered version of the namespace- nsChooseVersion :: M.Map String String+ nsChooseVersion :: M.Map Text Text } -- | Construct the generic config for a module. defaultOverrides :: Overrides defaultOverrides = Overrides {- constantPrefix = M.empty, ignoredElems = M.empty, ignoredAPIs = S.empty, sealedStructs = S.empty,@@ -52,7 +48,6 @@ instance Monoid Overrides where mempty = defaultOverrides mappend a b = Overrides {- constantPrefix = constantPrefix a <> constantPrefix b, ignoredAPIs = ignoredAPIs a <> ignoredAPIs b, sealedStructs = sealedStructs a <> sealedStructs b, ignoredElems = M.unionWith S.union (ignoredElems a) (ignoredElems b),@@ -65,7 +60,7 @@ -- | We have a bit of context (the current namespace), and can fail, -- encode this in a monad.-type Parser = WriterT Overrides (StateT (Maybe String) (Except Text)) ()+type Parser = WriterT Overrides (StateT (Maybe Text) (Except Text)) () -- | Parse the given config file (as a set of lines) for a given -- introspection namespace, filling in the configuration as needed. In@@ -82,10 +77,8 @@ parseOneLine line | T.null line = return () -- Comments parseOneLine (T.stripPrefix "#" -> Just _) = return ()-parseOneLine (T.stripPrefix "namespace " -> Just ns) =- (put . Just . T.unpack . T.strip) ns+parseOneLine (T.stripPrefix "namespace " -> Just ns) = (put . Just . T.strip) ns parseOneLine (T.stripPrefix "ignore " -> Just ign) = get >>= parseIgnore ign-parseOneLine (T.stripPrefix "constantPrefix " -> Just p) = get >>= parseConstP p parseOneLine (T.stripPrefix "seal " -> Just s) = get >>= parseSeal s parseOneLine (T.stripPrefix "pkg-config-name" -> Just s) = parsePkgConfigName s parseOneLine (T.stripPrefix "cabal-pkg-version" -> Just s) = parseCabalPkgVersion s@@ -93,30 +86,22 @@ parseOneLine l = throwError $ "Could not understand \"" <> l <> "\"." -- | Ignored elements.-parseIgnore :: Text -> Maybe String -> Parser+parseIgnore :: Text -> Maybe Text -> Parser parseIgnore _ Nothing = throwError "'ignore' requires a namespace to be defined first." parseIgnore (T.words -> [T.splitOn "." -> [api,elem]]) (Just ns) =- tell $ defaultOverrides {ignoredElems = M.singleton (Name ns (T.unpack api))+ tell $ defaultOverrides {ignoredElems = M.singleton (Name ns api) (S.singleton elem)} parseIgnore (T.words -> [T.splitOn "." -> [api]]) (Just ns) =- tell $ defaultOverrides {ignoredAPIs = S.singleton (Name ns (T.unpack api))}+ tell $ defaultOverrides {ignoredAPIs = S.singleton (Name ns api)} parseIgnore ignore _ = throwError ("Ignore syntax is of the form \"ignore API.elem\" with '.elem' optional.\nGot \"ignore " <> ignore <> "\" instead.") --- | Prefix for constants.-parseConstP :: Text -> Maybe String -> Parser-parseConstP _ Nothing = throwError "'constantPrefix' requires a namespace to be defined first. "-parseConstP (T.words -> [p]) (Just ns) = tell $- defaultOverrides {constantPrefix = M.singleton ns (T.unpack p)}-parseConstP prefix _ =- throwError ("constantPrefix syntax is of the form \"constantPrefix prefix\".\nGot \"constantPrefix " <> prefix <> "\" instead.")- -- | Sealed structures.-parseSeal :: Text -> Maybe String -> Parser+parseSeal :: Text -> Maybe Text -> Parser parseSeal _ Nothing = throwError "'seal' requires a namespace to be defined first." parseSeal (T.words -> [s]) (Just ns) = tell $- defaultOverrides {sealedStructs = S.singleton (Name ns (T.unpack s))}+ defaultOverrides {sealedStructs = S.singleton (Name ns s)} parseSeal seal _ = throwError ("seal syntax is of the form \"seal name\".\nGot \"seal " <> seal <> "\" instead.")@@ -135,7 +120,7 @@ parseNsVersion :: Text -> Parser parseNsVersion (T.words -> [ns,version]) = tell $ defaultOverrides {nsChooseVersion =- M.singleton (T.unpack ns) (T.unpack version)}+ M.singleton ns version} parseNsVersion t = throwError ("namespace-version syntax is of the form\n" <> "\t\"namespace-version namespace version\"\n" <>@@ -154,13 +139,10 @@ -- ignore. filterNamed :: [(Name, a)] -> S.Set Text -> [(Name, a)] filterNamed set ignores =- filter ((`S.notMember` ignores) . T.pack . name . fst) set+ filter ((`S.notMember` ignores) . name . fst) set -- | Filter one API according to the given config. filterOneAPI :: Overrides -> (Name, API, Maybe (S.Set Text)) -> (Name, API)-filterOneAPI ovs (Name ns n, APIConst c, _) =- (Name ns (prefix ++ n), APIConst c)- where prefix = fromMaybe "_" $ M.lookup ns (constantPrefix ovs) filterOneAPI ovs (n, APIStruct s, maybeIgnores) = (n, APIStruct s {structMethods = maybe (structMethods s) (filterNamed (structMethods s))
src/GI/ProjectInfo.hs view
@@ -10,18 +10,19 @@ ) where import Data.FileEmbed (embedStringFile)+import Data.Text (Text) -homepage :: String+homepage :: Text homepage = "https://github.com/haskell-gi/haskell-gi" -authors :: String+authors :: Text authors = "Will Thompson, Iñaki García Etxebarria and Jonas Platte" -maintainers :: String+maintainers :: Text maintainers = "Iñaki García Etxebarria (garetxe@gmail.com)" -license :: String+license :: Text license = "LGPL-2.1" -licenseText :: String+licenseText :: Text licenseText = $(embedStringFile "LICENSE")
src/GI/Properties.hs view
@@ -7,8 +7,7 @@ import Control.Applicative ((<$>)) #endif import Control.Monad (forM_, when, unless)-import Data.List (intercalate)-import Data.Monoid ((<>))+import Data.Text (Text) import qualified Data.Text as T import Foreign.Storable (sizeOf)@@ -19,11 +18,11 @@ import GI.Code import GI.GObject import GI.Inheritance (fullObjectPropertyList, fullInterfacePropertyList)-import GI.SymbolNaming (upperNameWithSuffix, upperName, classConstraint, qualifyWithSuffix, hyphensToCamelCase)+import GI.SymbolNaming (upperName, classConstraint, qualify, hyphensToCamelCase) import GI.Type import GI.Util -propTypeStr :: Type -> CodeGen String+propTypeStr :: Type -> CodeGen Text propTypeStr t = case t of TBasicType TUTF8 -> return "String" TBasicType TFileName -> return "String"@@ -77,50 +76,50 @@ -- Given a property, return the set of constraints on the types, and -- the type variables for the object and its value.-attrType :: Property -> CodeGen ([String], String)+attrType :: Property -> CodeGen ([Text], Text) attrType prop = do (_,t,constraints) <- argumentType ['a'..'l'] $ propType prop- if ' ' `elem` t+ if T.any (== ' ') t then return (constraints, parenthesize t) else return (constraints, t) -genPropertySetter :: Name -> String -> Property -> CodeGen ()+genPropertySetter :: Name -> Text -> Property -> CodeGen () genPropertySetter n pName prop = group $ do oName <- upperName n (constraints, t) <- attrType prop- let constraints' = "MonadIO m":(classConstraint oName ++ " o"):constraints+ let constraints' = "MonadIO m":(classConstraint oName <> " o"):constraints tStr <- propTypeStr $ propType prop- line $ "set" ++ pName ++ " :: (" ++ intercalate ", " constraints'- ++ ") => o -> " ++ t ++ " -> m ()"- line $ "set" ++ pName ++ " obj val = liftIO $ setObjectProperty" ++ tStr- ++ " obj \"" ++ T.unpack (propName prop) ++ "\" val"+ line $ "set" <> pName <> " :: (" <> T.intercalate ", " constraints'+ <> ") => o -> " <> t <> " -> m ()"+ line $ "set" <> pName <> " obj val = liftIO $ setObjectProperty" <> tStr+ <> " obj \"" <> propName prop <> "\" val" -genPropertyGetter :: Name -> String -> Property -> CodeGen ()+genPropertyGetter :: Name -> Text -> Property -> CodeGen () genPropertyGetter n pName prop = group $ do oName <- upperName n outType <- haskellType (propType prop)- let constraints = "(MonadIO m, " ++ classConstraint oName ++ " o)"- line $ "get" ++ pName ++ " :: " ++ constraints ++- " => o -> " ++ show ("m" `con` [outType])+ let constraints = "(MonadIO m, " <> classConstraint oName <> " o)"+ line $ "get" <> pName <> " :: " <> constraints <>+ " => o -> " <> tshow ("m" `con` [outType]) tStr <- propTypeStr $ propType prop- line $ "get" ++ pName ++ " obj = liftIO $ getObjectProperty" ++ tStr- ++ " obj \"" ++ T.unpack (propName prop) ++ "\"" +++ line $ "get" <> pName <> " obj = liftIO $ getObjectProperty" <> tStr+ <> " obj \"" <> propName prop <> "\"" <> if tStr `elem` ["Object", "Boxed"]- then " " ++ show outType -- These require the constructor too.+ then " " <> tshow outType -- These require the constructor too. else "" -genPropertyConstructor :: String -> Property -> CodeGen ()+genPropertyConstructor :: Text -> Property -> CodeGen () genPropertyConstructor pName prop = group $ do (constraints, t) <- attrType prop tStr <- propTypeStr $ propType prop let constraints' = case constraints of [] -> ""- _ -> parenthesize (intercalate ", " constraints) ++ " => "- line $ "construct" ++ pName ++ " :: " ++ constraints'- ++ t ++ " -> IO ([Char], GValue)"- line $ "construct" ++ pName ++ " val = constructObjectProperty" ++ tStr- ++ " \"" ++ T.unpack (propName prop) ++ "\" val"+ _ -> parenthesize (T.intercalate ", " constraints) <> " => "+ line $ "construct" <> pName <> " :: " <> constraints'+ <> t <> " -> IO ([Char], GValue)"+ line $ "construct" <> pName <> " val = constructObjectProperty" <> tStr+ <> " \"" <> propName prop <> "\" val" genObjectProperties :: Name -> Object -> CodeGen () genObjectProperties n o = do@@ -130,8 +129,8 @@ allProps <- fullObjectPropertyList n o >>= mapM (\(owner, prop) -> do pi <- infoType owner prop- return $ "'(\"" ++ T.unpack (propName prop)- ++ "\", " ++ pi ++ ")")+ return $ "'(\"" <> propName prop+ <> "\", " <> pi <> ")") genProperties n (objProperties o) allProps genInterfaceProperties :: Name -> Interface -> CodeGen ()@@ -139,34 +138,34 @@ allProps <- fullInterfacePropertyList n iface >>= mapM (\(owner, prop) -> do pi <- infoType owner prop- return $ "'(\"" ++ T.unpack (propName prop)- ++ "\", " ++ pi ++ ")")+ return $ "'(\"" <> propName prop+ <> "\", " <> pi <> ")") genProperties n (ifProperties iface) allProps -- If the given accesor is available (indicated by available == True), -- generate a fully qualified accesor name, otherwise just return -- "undefined". accessor is "get", "set" or "construct"-accessorOrUndefined :: Bool -> String -> Name -> String -> CodeGen String+accessorOrUndefined :: Bool -> Text -> Name -> Text -> CodeGen Text accessorOrUndefined available accessor (Name ons on) cName = if not available then return "undefined" else do- prefix <- qualifyWithSuffix "A." ons- return $ prefix ++ accessor ++ on ++ cName+ prefix <- qualify ons+ return $ prefix <> accessor <> on <> cName -- | The name of the type encoding the information for the property of -- the object.-infoType :: Name -> Property -> CodeGen String+infoType :: Name -> Property -> CodeGen Text infoType owner prop = do- name <- upperNameWithSuffix "A." owner- let cName = (hyphensToCamelCase . T.unpack . propName) prop- return $ name ++ cName ++ "PropertyInfo"+ name <- upperName owner+ let cName = (hyphensToCamelCase . propName) prop+ return $ name <> cName <> "PropertyInfo" genOneProperty :: Name -> Property -> ExcCodeGen () genOneProperty owner prop = do name <- upperName owner- let cName = (hyphensToCamelCase . T.unpack . propName) prop- pName = name ++ cName+ let cName = (hyphensToCamelCase . propName) prop+ pName = name <> cName flags = propFlags prop writable = PropertyWritable `elem` flags && (PropertyConstructOnly `notElem` flags)@@ -178,9 +177,9 @@ -- and the other possibilities are very uncommon, so let us just -- assume that TransferNothing is always the case. when (propTransfer prop /= TransferNothing) $- notImplementedError $ "Property " ++ pName- ++ " has unsupported transfer type "- ++ show (propTransfer prop)+ notImplementedError $ "Property " <> pName+ <> " has unsupported transfer type "+ <> tshow (propTransfer prop) getter <- accessorOrUndefined readable "get" owner cName setter <- accessorOrUndefined writable "set" owner cName@@ -189,12 +188,12 @@ unless (readable || writable || constructOnly) $ notImplementedError $ "Property is not readable, writable, or constructible: "- ++ show pName+ <> tshow pName group $ do- line $ "-- VVV Prop \"" ++ T.unpack (propName prop) ++ "\""- line $ " -- Type: " ++ show (propType prop)- line $ " -- Flags: " ++ show (propFlags prop)+ line $ "-- VVV Prop \"" <> propName prop <> "\""+ line $ " -- Type: " <> tshow (propType prop)+ line $ " -- Flags: " <> tshow (propFlags prop) when readable $ genPropertyGetter owner pName prop when writable $ genPropertySetter owner pName prop@@ -203,19 +202,19 @@ outType <- if not readable then return "()" else do- sOutType <- show <$> haskellType (propType prop)- return $ if ' ' `elem` sOutType+ sOutType <- tshow <$> haskellType (propType prop)+ return $ if T.any (== ' ') sOutType then parenthesize sOutType else sOutType -- Polymorphic _label style lens group $ do inIsGO <- isGObject (propType prop)- hInType <- show <$> haskellType (propType prop)+ hInType <- tshow <$> haskellType (propType prop) let inConstraint = if writable || constructOnly then if inIsGO then classConstraint hInType- else "(~) " ++ if ' ' `elem` hInType+ else "(~) " <> if T.any (== ' ') hInType then parenthesize hInType else hInType else "(~) ()"@@ -229,22 +228,25 @@ then ["'AttrGet"] else []) it <- infoType owner prop-- line $ "data " ++ it- line $ "instance AttrInfo " ++ it ++ " where"+ exportProperty cName it+ when (getter /= "undefined") (exportProperty cName getter)+ when (setter /= "undefined") (exportProperty cName setter)+ when (constructor /= "undefined") (exportProperty cName constructor)+ bline $ "data " <> it+ line $ "instance AttrInfo " <> it <> " where" indent $ do- line $ "type AttrAllowedOps " ++ it- ++ " = '[ " ++ intercalate ", " allowedOps ++ "]"- line $ "type AttrSetTypeConstraint " ++ it- ++ " = " ++ inConstraint- line $ "type AttrBaseTypeConstraint " ++ it- ++ " = " ++ classConstraint name- line $ "type AttrGetType " ++ it ++ " = " ++ outType- line $ "type AttrLabel " ++ it ++ " = \""- ++ name ++ "::" ++ T.unpack (propName prop) ++ "\""- line $ "attrGet _ = " ++ getter- line $ "attrSet _ = " ++ setter- line $ "attrConstruct _ = " ++ constructor+ line $ "type AttrAllowedOps " <> it+ <> " = '[ " <> T.intercalate ", " allowedOps <> "]"+ line $ "type AttrSetTypeConstraint " <> it+ <> " = " <> inConstraint+ line $ "type AttrBaseTypeConstraint " <> it+ <> " = " <> classConstraint name+ line $ "type AttrGetType " <> it <> " = " <> outType+ line $ "type AttrLabel " <> it <> " = \""+ <> name <> "::" <> propName prop <> "\""+ line $ "attrGet _ = " <> getter+ line $ "attrSet _ = " <> setter+ line $ "attrConstruct _ = " <> constructor -- | Generate a placeholder property for those cases in which code -- generation failed.@@ -252,29 +254,34 @@ genPlaceholderProperty owner prop = do line $ "-- XXX Placeholder" it <- infoType owner prop- line $ "data " ++ it- line $ "instance AttrInfo " ++ it ++ " where"+ let cName = (hyphensToCamelCase . propName) prop+ exportProperty cName it+ line $ "data " <> it+ line $ "instance AttrInfo " <> it <> " where" indent $ do- line $ "type AttrAllowedOps " ++ it ++ " = '[]"- line $ "type AttrSetTypeConstraint " ++ it ++ " = (~) ()"- line $ "type AttrBaseTypeConstraint " ++ it ++ " = (~) ()"- line $ "type AttrGetType " ++ it ++ " = ()"- line $ "type AttrLabel " ++ it ++ " = \"\""+ line $ "type AttrAllowedOps " <> it <> " = '[]"+ line $ "type AttrSetTypeConstraint " <> it <> " = (~) ()"+ line $ "type AttrBaseTypeConstraint " <> it <> " = (~) ()"+ line $ "type AttrGetType " <> it <> " = ()"+ line $ "type AttrLabel " <> it <> " = \"\"" line $ "attrGet = undefined" line $ "attrSet = undefined" line $ "attrConstruct = undefined" -genProperties :: Name -> [Property] -> [String] -> CodeGen ()+genProperties :: Name -> [Property] -> [Text] -> CodeGen () genProperties n ownedProps allProps = do name <- upperName n forM_ ownedProps $ \prop -> do handleCGExc (\err -> do line $ "-- XXX Generation of property \""- ++ T.unpack (propName prop) ++ "\" of object \""- ++ name ++ "\" failed: " ++ describeCGError err+ <> propName prop <> "\" of object \""+ <> name <> "\" failed: " <> describeCGError err genPlaceholderProperty n prop) (genOneProperty n prop) - group $ line $ "type instance AttributeList " ++ name ++ " = '[ "- ++ intercalate ", " allProps ++ "]"+ group $ do+ let propListType = name <> "AttributeList"+ line $ "type instance AttributeList " <> name <> " = " <> propListType+ line $ "type " <> propListType <> " = ('[ "+ <> T.intercalate ", " allProps <> "] :: [(Symbol, *)])"
src/GI/Signal.hs view
@@ -9,10 +9,10 @@ #endif import Control.Monad (forM, forM_, when, unless) -import Data.List (intercalate) import Data.Typeable (typeOf) import Data.Bool (bool) import qualified Data.Text as T+import Data.Text (Text) import Text.Show.Pretty (ppShow) @@ -23,34 +23,39 @@ import GI.SymbolNaming import GI.Transfer (freeContainerType) import GI.Type-import GI.Util (split, parenthesize, withComment)+import GI.Util (parenthesize, withComment, tshow, terror, ucFirst, lcFirst) -- The prototype of the callback on the Haskell side (what users of -- the binding will see)-genHaskellCallbackPrototype :: Callable -> String -> [Arg] -> [Arg] ->+genHaskellCallbackPrototype :: Text -> Callable -> Text -> [Arg] -> [Arg] -> ExcCodeGen ()-genHaskellCallbackPrototype cb name' hInArgs hOutArgs = do+genHaskellCallbackPrototype subsec cb name' hInArgs hOutArgs = do group $ do- line $ "type " ++ name' ++ " ="+ exportSignal subsec name'+ line $ "type " <> name' <> " =" indent $ do forM_ hInArgs $ \arg -> do ht <- haskellType (argType arg) wrapMaybe arg >>= bool- (line $ show ht ++ " ->")- (line $ show (maybeT ht) ++ " ->")+ (line $ tshow ht <> " ->")+ (line $ tshow (maybeT ht) <> " ->") ret <- hOutType cb hOutArgs False- line $ show $ io ret+ line $ tshow $ io ret -- For optional parameters, in case we want to pass Nothing. group $ do- line $ "no" ++ name' ++ " :: Maybe " ++ name'- line $ "no" ++ name' ++ " = Nothing"+ exportSignal subsec ("no" <> name')+ line $ "no" <> name' <> " :: Maybe " <> name'+ line $ "no" <> name' <> " = Nothing" -- Prototype of the callback on the C side-genCCallbackPrototype :: Callable -> String -> Bool -> CodeGen ()-genCCallbackPrototype cb name' isSignal =+genCCallbackPrototype :: Text -> Callable -> Text -> Bool -> CodeGen ()+genCCallbackPrototype subsec cb name' isSignal = group $ do- line $ "type " ++ name' ++ "C ="+ let ctypeName = name' <> "C"+ exportSignal subsec ctypeName++ line $ "type " <> ctypeName <> " =" indent $ do when isSignal $ line $ withComment "Ptr () ->" "object" forM_ (args cb) $ \arg -> do@@ -58,50 +63,53 @@ let ht' = if direction arg /= DirectionIn then ptr ht else ht- line $ show ht' ++ " ->"+ line $ tshow ht' <> " ->" when isSignal $ line $ withComment "Ptr () ->" "user_data" ret <- io <$> case returnType cb of TBasicType TVoid -> return $ typeOf () t -> foreignType t- line $ show ret+ line $ tshow ret -- Generator for wrappers callable from C-genCallbackWrapperFactory :: String -> CodeGen ()-genCallbackWrapperFactory name' =+genCallbackWrapperFactory :: Text -> Text -> CodeGen ()+genCallbackWrapperFactory subsec name' = group $ do+ let factoryName = "mk" <> name' line "foreign import ccall \"wrapper\""- indent $ line $ "mk" ++ name' ++ " :: "- ++ name' ++ "C -> IO (FunPtr " ++ name' ++ "C)"+ indent $ line $ factoryName <> " :: "+ <> name' <> "C -> IO (FunPtr " <> name' <> "C)"+ exportSignal subsec factoryName -- Generator of closures-genClosure :: String -> String -> Bool -> CodeGen ()-genClosure callback closure isSignal =- group $ do- line $ closure ++ " :: " ++ callback ++ " -> IO Closure"- line $ closure ++ " cb = newCClosure =<< mk" ++ callback ++ " wrapped"+genClosure :: Text -> Text -> Text -> Bool -> CodeGen ()+genClosure subsec callback closure isSignal = do+ exportSignal subsec closure+ group $ do+ line $ closure <> " :: " <> callback <> " -> IO Closure"+ line $ closure <> " cb = newCClosure =<< mk" <> callback <> " wrapped" indent $- line $ "where wrapped = " ++ lcFirst callback ++ "Wrapper " +++ line $ "where wrapped = " <> lcFirst callback <> "Wrapper " <> if isSignal then "cb" else "Nothing cb" -- Wrap a conversion of a nullable object into "Maybe" object, by -- checking whether the pointer is NULL.-convertNullable :: String -> BaseCodeGen e String -> BaseCodeGen e String+convertNullable :: Text -> BaseCodeGen e Text -> BaseCodeGen e Text convertNullable aname c = do- line $ "maybe" ++ ucFirst aname ++ " <-"+ line $ "maybe" <> ucFirst aname <> " <-" indent $ do- line $ "if " ++ aname ++ " == nullPtr"+ line $ "if " <> aname <> " == nullPtr" line "then return Nothing" line "else do" indent $ do unpacked <- c- line $ "return $ Just " ++ unpacked- return $ "maybe" ++ ucFirst aname+ line $ "return $ Just " <> unpacked+ return $ "maybe" <> ucFirst aname -- Convert a non-zero terminated out array, stored in a variable -- named "aname", into the corresponding Haskell object.-convertCallbackInCArray :: Callable -> Arg -> Type -> String -> ExcCodeGen String+convertCallbackInCArray :: Callable -> Arg -> Type -> Text -> ExcCodeGen Text convertCallbackInCArray callable arg t@(TCArray False (-1) length _) aname = if length > -1 then wrapMaybe arg >>= bool convertAndFree@@ -113,7 +121,7 @@ where lname = escapeReserved $ argName $ args callable !! length - convertAndFree :: ExcCodeGen String+ convertAndFree :: ExcCodeGen Text convertAndFree = do unpacked <- convert aname $ unpackCArray lname t (transfer arg) -- Free the memory associated with the array@@ -122,16 +130,16 @@ -- Remove the warning, this should never be reached. convertCallbackInCArray _ t _ _ =- error $ "convertOutCArray : unexpected " ++ show t+ terror $ "convertOutCArray : unexpected " <> tshow t -- Prepare an argument for passing into the Haskell side.-prepareArgForCall :: Callable -> Arg -> ExcCodeGen String+prepareArgForCall :: Callable -> Arg -> ExcCodeGen Text prepareArgForCall cb arg = case direction arg of DirectionIn -> prepareInArg cb arg DirectionInout -> prepareInoutArg arg- DirectionOut -> error "Unexpected DirectionOut!"+ DirectionOut -> terror "Unexpected DirectionOut!" -prepareInArg :: Callable -> Arg -> ExcCodeGen String+prepareInArg :: Callable -> Arg -> ExcCodeGen Text prepareInArg cb arg = do let name = (escapeReserved . argName) arg case argType arg of@@ -140,7 +148,7 @@ let c = convert name $ fToH (argType arg) (transfer arg) wrapMaybe arg >>= bool c (convertNullable name c) -prepareInoutArg :: Arg -> ExcCodeGen String+prepareInoutArg :: Arg -> ExcCodeGen Text prepareInoutArg arg = do let name = (escapeReserved . argName) arg name' <- genConversion name $ apply $ M "peek"@@ -149,11 +157,11 @@ saveOutArg :: Arg -> ExcCodeGen () saveOutArg arg = do let name = (escapeReserved . argName) arg- name' = "out" ++ name+ name' = "out" <> name when (transfer arg /= TransferEverything) $- notImplementedError $ "Unexpected transfer type for \"" ++ name ++ "\""+ notImplementedError $ "Unexpected transfer type for \"" <> name <> "\"" name'' <- convert name' $ hToF (argType arg) TransferEverything- line $ "poke " ++ name ++ " " ++ name''+ line $ "poke " <> name <> " " <> name'' -- The wrapper itself, marshalling to and from Haskell. The first -- argument is possibly a pointer to a FunPtr to free (via@@ -161,37 +169,40 @@ -- FunPtr will be freed by someone else (the function registering the -- callback for ScopeTypeCall, or a destroy notifier for -- ScopeTypeNotified).-genCallbackWrapper :: Callable -> String -> [Arg] -> [Arg] -> [Arg] ->+genCallbackWrapper :: Text -> Callable -> Text -> [Arg] -> [Arg] -> [Arg] -> Bool -> ExcCodeGen ()-genCallbackWrapper cb name' dataptrs hInArgs hOutArgs isSignal = do+genCallbackWrapper subsec cb name' dataptrs hInArgs hOutArgs isSignal = do let cName arg = if arg `elem` dataptrs then "_" else (escapeReserved . argName) arg cArgNames = map cName (args cb)+ wrapperName = lcFirst name' <> "Wrapper" + exportSignal subsec wrapperName+ group $ do- line $ lcFirst name' ++ "Wrapper ::"+ line $ wrapperName <> " ::" indent $ do unless isSignal $- line $ "Maybe (Ptr (FunPtr (" ++ name' ++ "C))) ->"- line $ name' ++ " ->"+ line $ "Maybe (Ptr (FunPtr (" <> name' <> "C))) ->"+ line $ name' <> " ->" when isSignal $ line "Ptr () ->" forM_ (args cb) $ \arg -> do ht <- foreignType $ argType arg let ht' = if direction arg /= DirectionIn then ptr ht else ht- line $ show ht' ++ " ->"+ line $ tshow ht' <> " ->" when isSignal $ line "Ptr () ->" ret <- io <$> case returnType cb of TBasicType TVoid -> return $ typeOf () t -> foreignType t- line $ show ret+ line $ tshow ret let allArgs = if isSignal- then unwords $ ["_cb", "_"] ++ cArgNames ++ ["_"]- else unwords $ ["funptrptr", "_cb"] ++ cArgNames- line $ lcFirst name' ++ "Wrapper " ++ allArgs ++ " = do"+ then T.unwords $ ["_cb", "_"] <> cArgNames <> ["_"]+ else T.unwords $ ["funptrptr", "_cb"] <> cArgNames+ line $ wrapperName <> " " <> allArgs <> " = do" indent $ do hInNames <- forM hInArgs (prepareArgForCall cb) @@ -199,12 +210,12 @@ TBasicType TVoid -> [] _ -> ["result"] argName' = escapeReserved . argName- returnVars = maybeReturn ++ map (("out"++) . argName') hOutArgs+ returnVars = maybeReturn <> map (("out"<>) . argName') hOutArgs returnBind = case returnVars of [] -> ""- [r] -> r ++ " <- "- _ -> parenthesize (intercalate ", " returnVars) ++ " <- "- line $ returnBind ++ "_cb " ++ concatMap (" " ++) hInNames+ [r] -> r <> " <- "+ _ -> parenthesize (T.intercalate ", " returnVars) <> " <- "+ line $ returnBind <> "_cb " <> T.concat (map (" " <>) hInNames) forM_ hOutArgs saveOutArg @@ -219,16 +230,16 @@ where unwrapped rname = do result' <- convert rname $ hToF (returnType cb) (returnTransfer cb)- line $ "return " ++ result'+ line $ "return " <> result' genCallback :: Name -> Callback -> CodeGen ()-genCallback n (Callback cb) = do+genCallback n (Callback cb) = submodule "Callbacks" $ do name' <- upperName n- line $ "-- callback " ++ name'+ line $ "-- callback " <> name' let -- user_data pointers, which we generically omit dataptrs = map (args cb !!) . filter (/= -1) . map argClosure $ args cb- hidden = dataptrs ++ arrayLengths cb+ hidden = dataptrs <> arrayLengths cb inArgs = filter ((/= DirectionOut) . direction) $ args cb hInArgs = filter (not . (`elem` hidden)) inArgs@@ -237,50 +248,50 @@ if skipReturn cb then group $ do- line $ "-- XXX Skipping callback " ++ name'+ line $ "-- XXX Skipping callback " <> name' line $ "-- Callbacks skipping return unsupported :\n"- ++ ppShow n ++ "\n" ++ ppShow cb+ <> T.pack (ppShow n) <> "\n" <> T.pack (ppShow cb) else do- let closure = lcFirst name' ++ "Closure"+ let closure = lcFirst name' <> "Closure" handleCGExc (\e -> line ("-- XXX Could not generate callback wrapper for "- ++ name' ++- "\n-- Error was : " ++ describeCGError e))- (genClosure name' closure False >>- genCCallbackPrototype cb name' False >>- genCallbackWrapperFactory name' >>- genHaskellCallbackPrototype cb name' hInArgs hOutArgs >>- genCallbackWrapper cb name' dataptrs hInArgs hOutArgs False)+ <> name' <>+ "\n-- Error was : " <> describeCGError e))+ (genClosure name' name' closure False >>+ genCCallbackPrototype name' cb name' False >>+ genCallbackWrapperFactory name' name' >>+ genHaskellCallbackPrototype name' cb name' hInArgs hOutArgs >>+ genCallbackWrapper name' cb name' dataptrs hInArgs hOutArgs False) -- | Return the name for the signal in Haskell CamelCase conventions.-signalHaskellName :: String -> String-signalHaskellName sn = let (w:ws) = split '-' sn- in w ++ concatMap ucFirst ws+signalHaskellName :: Text -> Text+signalHaskellName sn = let (w:ws) = T.split (== '-') sn+ in w <> T.concat (map ucFirst ws) genSignal :: Signal -> Name -> ExcCodeGen () genSignal (Signal { sigName = sn, sigCallable = cb }) on = do on' <- upperName on - line $ "-- signal " ++ on' ++ "::" ++ T.unpack sn+ line $ "-- signal " <> on' <> "::" <> sn let inArgs = filter ((/= DirectionOut) . direction) $ args cb hInArgs = filter (not . (`elem` arrayLengths cb)) inArgs outArgs = filter ((/= DirectionIn) . direction) $ args cb hOutArgs = filter (not . (`elem` arrayLengths cb)) outArgs- sn' = signalHaskellName (T.unpack sn)- signalConnectorName = on' ++ ucFirst sn'- cbType = signalConnectorName ++ "Callback"+ sn' = signalHaskellName (sn)+ signalConnectorName = on' <> ucFirst sn'+ cbType = signalConnectorName <> "Callback" - genHaskellCallbackPrototype cb cbType hInArgs hOutArgs+ genHaskellCallbackPrototype (ucFirst sn') cb cbType hInArgs hOutArgs - genCCallbackPrototype cb cbType True+ genCCallbackPrototype (ucFirst sn') cb cbType True - genCallbackWrapperFactory cbType+ genCallbackWrapperFactory (ucFirst sn') cbType - let closure = lcFirst signalConnectorName ++ "Closure"- genClosure cbType closure True+ let closure = lcFirst signalConnectorName <> "Closure"+ genClosure (ucFirst sn') cbType closure True - genCallbackWrapper cb cbType [] hInArgs hOutArgs True+ genCallbackWrapper (ucFirst sn') cb cbType [] hInArgs hOutArgs True -- Wrapper for connecting functions to the signal -- We can connect to a signal either before the default handler runs@@ -288,25 +299,27 @@ -- provide convenient wrappers for both cases. group $ do let signatureConstraints = "(GObject a, MonadIO m) =>"- signatureArgs = "a -> " ++ cbType ++ " -> m SignalHandlerId"- signature = " :: " ++ signatureConstraints ++ " " ++ signatureArgs- onName = "on" ++ signalConnectorName- afterName = "after" ++ signalConnectorName- line $ onName ++ signature- line $ onName ++ " obj cb = liftIO $ connect"- ++ signalConnectorName ++ " obj cb SignalConnectBefore"- line $ afterName ++ signature- line $ afterName ++ " obj cb = connect"- ++ signalConnectorName ++ " obj cb SignalConnectAfter"+ signatureArgs = "a -> " <> cbType <> " -> m SignalHandlerId"+ signature = " :: " <> signatureConstraints <> " " <> signatureArgs+ onName = "on" <> signalConnectorName+ afterName = "after" <> signalConnectorName+ line $ onName <> signature+ line $ onName <> " obj cb = liftIO $ connect"+ <> signalConnectorName <> " obj cb SignalConnectBefore"+ line $ afterName <> signature+ line $ afterName <> " obj cb = connect"+ <> signalConnectorName <> " obj cb SignalConnectAfter"+ exportSignal (ucFirst sn') onName+ exportSignal (ucFirst sn') afterName group $ do- let fullName = "connect" ++ signalConnectorName+ let fullName = "connect" <> signalConnectorName signatureConstraints = "(GObject a, MonadIO m) =>"- signatureArgs = "a -> " ++ cbType- ++ " -> SignalConnectMode -> m SignalHandlerId"- line $ fullName ++ " :: " ++ signatureConstraints- line $ replicate (4 + length fullName) ' ' ++ signatureArgs- line $ fullName ++ " obj cb after = liftIO $ do"+ signatureArgs = "a -> " <> cbType+ <> " -> SignalConnectMode -> m SignalHandlerId"+ line $ fullName <> " :: " <> signatureConstraints+ line $ T.replicate (4 + T.length fullName) " " <> signatureArgs+ line $ fullName <> " obj cb after = liftIO $ do" indent $ do- line $ "cb' <- mk" ++ cbType ++ " (" ++ lcFirst cbType ++ "Wrapper cb)"- line $ "connectSignalFunPtr obj \"" ++ T.unpack sn ++ "\" cb' after"+ line $ "cb' <- mk" <> cbType <> " (" <> lcFirst cbType <> "Wrapper cb)"+ line $ "connectSignalFunPtr obj \"" <> sn <> "\" cb' after"
src/GI/Struct.hs view
@@ -9,9 +9,9 @@ #endif import Control.Monad (forM_, unless, when) -import Data.List (isSuffixOf) import Data.Maybe (mapMaybe, isJust)-import Data.Text (unpack)+import Data.Text (Text)+import qualified Data.Text as T import GI.API import GI.Conversions@@ -23,15 +23,13 @@ -- | Whether (not) to generate bindings for the given struct. ignoreStruct :: Name -> Struct -> Bool ignoreStruct (Name _ name) s = isJust (gtypeStructFor s) ||- "Private" `isSuffixOf` name+ "Private" `T.isSuffixOf` name -- | Canonical name for the type of a callback type embedded in a -- struct field.-fieldCallbackType :: String -> Field -> String-fieldCallbackType structName field = structName- ++ (underscoresToCamelCase . unpack .- fieldName) field- ++ "FieldCallback"+fieldCallbackType :: Text -> Field -> Text+fieldCallbackType structName field =+ structName <> (underscoresToCamelCase . fieldName) field <> "FieldCallback" -- | Fix the interface names of callback fields in the struct to -- correspond to the ones that we are going to generate.@@ -74,30 +72,32 @@ buildFieldGetter n@(Name ns _) field = do name' <- upperName n - hType <- show <$> haskellType (fieldType field)- fType <- show <$> foreignType (fieldType field)- unless ("Private" `isSuffixOf` hType) $ do- fName <- upperName $ Name ns (unpack . fieldName $ field)- let getter = lcFirst name' ++ "Read" ++ fName- line $ getter ++ " :: " ++ name' ++ " -> IO " ++- if ' ' `elem` hType+ hType <- tshow <$> haskellType (fieldType field)+ fType <- tshow <$> foreignType (fieldType field)+ unless ("Private" `T.isSuffixOf` hType) $ do+ fName <- upperName $ Name ns (fieldName field)+ let getter = lcFirst name' <> "Read" <> fName+ line $ getter <> " :: " <> name' <> " -> IO " <>+ if T.any (== ' ') hType then parenthesize hType else hType- line $ getter ++ " s = withManagedPtr s $ \\ptr -> do"+ line $ getter <> " s = withManagedPtr s $ \\ptr -> do" indent $ do- line $ "val <- peek (ptr `plusPtr` " ++ show (fieldOffset field)- ++ ") :: IO " ++ if ' ' `elem` fType+ line $ "val <- peek (ptr `plusPtr` " <> tshow (fieldOffset field)+ <> ") :: IO " <> if T.any (== ' ') fType then parenthesize fType else fType result <- convert "val" $ fToH (fieldType field) TransferNothing- line $ "return " ++ result+ line $ "return " <> result + exportProperty fName getter+ genStructOrUnionFields :: Name -> [Field] -> CodeGen () genStructOrUnionFields n fields = do name' <- upperName n forM_ fields $ \field -> when (fieldVisible field) $ group $- handleCGExc (\e -> line ("-- XXX Skipped getter for \"" ++ name' ++- ":" ++ unpack (fieldName field) ++ "\" :: " +++ handleCGExc (\e -> line ("-- XXX Skipped getter for \"" <> name' <>+ ":" <> fieldName field <> "\" :: " <> describeCGError e)) (buildFieldGetter n field)
src/GI/SymbolNaming.hs view
@@ -1,11 +1,8 @@+{-# LANGUAGE ViewPatterns #-} module GI.SymbolNaming ( qualify- , qualifyWithSuffix- , ucFirst- , lcFirst , lowerName , upperName- , upperNameWithSuffix , noName , escapeReserved , classConstraint@@ -13,32 +10,22 @@ , underscoresToCamelCase ) where -import Data.Char (toLower, toUpper) #if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid, (<>))-#else-import Data.Monoid ((<>))+import Data.Monoid (Monoid) #endif import Data.Text (Text) import qualified Data.Text as T-import Data.String (IsString) import GI.API import GI.Code import GI.Config (Config(modName))-import GI.Util (split)+import GI.Util (lcFirst, ucFirst) -classConstraint :: (Monoid a, IsString a) => a -> a+classConstraint :: Text -> Text classConstraint n = n <> "K" -ucFirst (x:xs) = toUpper x : xs-ucFirst "" = error "ucFirst: empty string"--lcFirst (x:xs) = toLower x : xs-lcFirst "" = error "lcFirst: empty string"--lowerName :: Name -> CodeGen String-lowerName (Name _ s) = return $ concat . rename $ split '_' s+lowerName :: Name -> CodeGen Text+lowerName (Name _ s) = return . T.concat . rename . T.split (== '_') $ s where rename [w] = [lcFirst w] rename (w:ws) = lcFirst w : map ucFirst' ws@@ -47,57 +34,58 @@ ucFirst' "" = "_" ucFirst' x = ucFirst x -upperNameWithSuffix :: String -> Name -> CodeGen String+upperNameWithSuffix :: Text -> Name -> CodeGen Text upperNameWithSuffix suffix (Name ns s) = do prefix <- qualifyWithSuffix suffix ns- return $ prefix ++ uppered- where uppered = concatMap ucFirst' $ split '_' $ sanitize s+ return $ prefix <> uppered+ where uppered = T.concat . map ucFirst' . T.split (== '_') $ sanitize s -- Move leading underscores to the end (for example in -- GObject::_Value_Data_Union -> GObject::Value_Data_Union_)- sanitize ('_':xs) = sanitize xs ++ "_"+ sanitize (T.uncons -> Just ('_', xs)) = sanitize xs <> "_" sanitize xs = xs ucFirst' "" = "_" ucFirst' x = ucFirst x -upperName :: Name -> CodeGen String+upperName :: Name -> CodeGen Text upperName = upperNameWithSuffix "." -- | Return a qualified prefix for the given namespace. In case the -- namespace corresponds to the current module the empty string is -- returned, otherwise the namespace ++ suffix is returned. Suffix is -- typically just ".", see `qualify` below.-qualifyWithSuffix :: String -> String -> CodeGen String+qualifyWithSuffix :: Text -> Text -> CodeGen Text qualifyWithSuffix suffix ns = do cfg <- config if modName cfg == Just ns then return "" else do- loadDependency ns -- Make sure that the given namespace is listed- -- as a dependency of this module.- return $ ucFirst ns ++ suffix+ loadDependency ns -- Make sure that the given namespace is+ -- listed as a dependency of this module.+ return $ ucFirst ns <> suffix -- | Return the qualified namespace (ns ++ "." or "", depending on -- whether ns is the current namespace).-qualify :: String -> CodeGen String+qualify :: Text -> CodeGen Text qualify = qualifyWithSuffix "." -- | Save a bit of typing for optional arguments in the case that we -- want to pass Nothing.-noName :: String -> CodeGen ()+noName :: Text -> CodeGen () noName name' = group $ do- line $ "no" ++ name' ++ " :: Maybe " ++ name'- line $ "no" ++ name' ++ " = Nothing"+ line $ "no" <> name' <> " :: Maybe " <> name'+ line $ "no" <> name' <> " = Nothing"+ exportDecl ("no" <> name') -- | For a string of the form "one-sample-string" return "OneSampleString"-hyphensToCamelCase :: String -> String-hyphensToCamelCase str = concatMap ucFirst $ split '-' str+hyphensToCamelCase :: Text -> Text+hyphensToCamelCase = T.concat . map ucFirst . T.split (== '-') -- | Similarly, turn a name separated_by_underscores into CamelCase.-underscoresToCamelCase :: String -> String-underscoresToCamelCase str = concatMap ucFirst $ split '_' str+underscoresToCamelCase :: Text -> Text+underscoresToCamelCase = T.concat . map ucFirst . T.split (== '_') -escapeReserved :: Text -> String+escapeReserved :: Text -> Text escapeReserved "type" = "type_" escapeReserved "in" = "in_" escapeReserved "data" = "data_"@@ -124,6 +112,6 @@ escapeReserved "when" = "when_" escapeReserved "default" = "default_" escapeReserved s- | "set_" `T.isPrefixOf` s = T.unpack s <> "_"- | "get_" `T.isPrefixOf` s = T.unpack s <> "_"- | otherwise = T.unpack s+ | "set_" `T.isPrefixOf` s = s <> "_"+ | "get_" `T.isPrefixOf` s = s <> "_"+ | otherwise = s
src/GI/Transfer.hs view
@@ -12,12 +12,12 @@ import Control.Monad (when) import Data.Maybe (isJust)+import Data.Text (Text) import GI.API import GI.Code import GI.Conversions import GI.GObject-import GI.SymbolNaming (ucFirst) import GI.Type import GI.Util @@ -25,7 +25,7 @@ -- Haskell objects with memory managed by the GC should not be freed -- here. For containers this is only for freeing the container itself, -- freeing the elements is done separately.-basicFreeFn :: Type -> Maybe String+basicFreeFn :: Type -> Maybe Text basicFreeFn (TBasicType TUTF8) = Just "freeMem" basicFreeFn (TBasicType TFileName) = Just "freeMem" basicFreeFn (TBasicType _) = Nothing@@ -46,7 +46,7 @@ -- run in the exception handler, so any type which we ref/allocate -- with the expectation that the called function will consume it (on -- TransferEverything) should be freed here.-basicFreeFnOnError :: Type -> Transfer -> CodeGen (Maybe String)+basicFreeFnOnError :: Type -> Transfer -> CodeGen (Maybe Text) basicFreeFnOnError (TBasicType TUTF8) _ = return $ Just "freeMem" basicFreeFnOnError (TBasicType TFileName) _ = return $ Just "freeMem" basicFreeFnOnError (TBasicType _) _ = return Nothing@@ -107,46 +107,46 @@ basicFreeFnOnError (TError) _ = return Nothing -- Free just the container, but not the elements.-freeContainer :: Type -> String -> CodeGen [String]+freeContainer :: Type -> Text -> CodeGen [Text] freeContainer t label = case basicFreeFn t of Nothing -> return []- Just fn -> return [fn ++ " " ++ label]+ Just fn -> return [fn <> " " <> label] -- Free one element using the given free function.-freeElem :: Type -> String -> String -> ExcCodeGen String+freeElem :: Type -> Text -> Text -> ExcCodeGen Text freeElem t label free = case elementTypeAndMap t undefined of Nothing -> return free Just (TCArray False _ _ _, _) ->- badIntroError $ "Element type in container \"" ++ label +++ badIntroError $ "Element type in container \"" <> label <> "\" is an array of unknown length." Just (innerType, mapFn) -> do- let elemFree = "freeElemOf" ++ ucFirst label+ let elemFree = "freeElemOf" <> ucFirst label fullyFree innerType (prime label) >>= \case- Nothing -> return $ free ++ " e"+ Nothing -> return $ free <> " e" Just elemInnerFree -> do- line $ "let " ++ elemFree ++ " e = " ++ mapFn ++ " "- ++ elemInnerFree ++ " e >> " ++ free ++ " e"+ line $ "let " <> elemFree <> " e = " <> mapFn <> " "+ <> elemInnerFree <> " e >> " <> free <> " e" return elemFree -- Construct a function to free the memory associated with a type, and -- recursively free any elements of this type in case that it is a -- container.-fullyFree :: Type -> String -> ExcCodeGen (Maybe String)+fullyFree :: Type -> Text -> ExcCodeGen (Maybe Text) fullyFree t label = case basicFreeFn t of Nothing -> return Nothing Just free -> Just <$> freeElem t label free -- Like fullyFree, but free the toplevel element using basicFreeFnOnError.-fullyFreeOnError :: Type -> String -> Transfer -> ExcCodeGen (Maybe String)+fullyFreeOnError :: Type -> Text -> Transfer -> ExcCodeGen (Maybe Text) fullyFreeOnError t label transfer = basicFreeFnOnError t transfer >>= \case Nothing -> return Nothing Just free -> Just <$> freeElem t label free -- Free the elements in a container type.-freeElements :: Type -> String -> String -> ExcCodeGen [String]+freeElements :: Type -> Text -> Text -> ExcCodeGen [Text] freeElements t label len = case elementTypeAndMap t len of Nothing -> return []@@ -154,11 +154,11 @@ fullyFree inner label >>= \case Nothing -> return [] Just innerFree ->- return [mapFn ++ " " ++ innerFree ++ " " ++ label]+ return [mapFn <> " " <> innerFree <> " " <> label] -- | Free a container and/or the contained elements, depending on the -- transfer mode.-freeContainerType :: Transfer -> Type -> String -> String -> ExcCodeGen ()+freeContainerType :: Transfer -> Type -> Text -> Text -> ExcCodeGen () freeContainerType transfer (TGHash _ _) label _ = freeGHashTable transfer label freeContainerType transfer t label len = do when (transfer == TransferEverything) $@@ -166,23 +166,23 @@ when (transfer /= TransferNothing) $ mapM_ line =<< freeContainer t label -freeGHashTable :: Transfer -> String -> ExcCodeGen ()+freeGHashTable :: Transfer -> Text -> ExcCodeGen () freeGHashTable TransferNothing _ = return () freeGHashTable TransferContainer label = notImplementedError $ "Hash table argument with transfer = Container? "- ++ label+ <> label -- Hash tables support setting a free function for keys and elements, -- we assume that these are always properly set. The worst that can -- happen this way is a memory leak, as opposed to a double free if we -- try do free anything here. freeGHashTable TransferEverything label =- line $ "unrefGHashTable " ++ label+ line $ "unrefGHashTable " <> label -- Free the elements of a container type in the case an error ocurred, -- in particular args that should have been transferred did not get -- transfered.-freeElementsOnError :: Transfer -> Type -> String -> String ->- ExcCodeGen [String]+freeElementsOnError :: Transfer -> Type -> Text -> Text ->+ ExcCodeGen [Text] freeElementsOnError transfer t label len = case elementTypeAndMap t len of Nothing -> return []@@ -190,40 +190,40 @@ fullyFreeOnError inner label transfer >>= \case Nothing -> return [] Just innerFree ->- return [mapFn ++ " " ++ innerFree ++ " " ++ label]+ return [mapFn <> " " <> innerFree <> " " <> label] -freeIn :: Transfer -> Type -> String -> String -> ExcCodeGen [String]+freeIn :: Transfer -> Type -> Text -> Text -> ExcCodeGen [Text] freeIn transfer (TGHash _ _) label _ = freeInGHashTable transfer label freeIn transfer t label len = case transfer of- TransferNothing -> (++) <$> freeElements t label len <*> freeContainer t label+ TransferNothing -> (<>) <$> freeElements t label len <*> freeContainer t label TransferContainer -> freeElements t label len TransferEverything -> return [] -freeInOnError :: Transfer -> Type -> String -> String -> ExcCodeGen [String]+freeInOnError :: Transfer -> Type -> Text -> Text -> ExcCodeGen [Text] freeInOnError transfer (TGHash _ _) label _ = freeInGHashTable transfer label freeInOnError transfer t label len =- (++) <$> freeElementsOnError transfer t label len+ (<>) <$> freeElementsOnError transfer t label len <*> freeContainer t label -- See freeGHashTable above.-freeInGHashTable :: Transfer -> String -> ExcCodeGen [String]+freeInGHashTable :: Transfer -> Text -> ExcCodeGen [Text] freeInGHashTable TransferEverything _ = return [] freeInGHashTable TransferContainer label = notImplementedError $ "Hash table argument with TransferContainer? "- ++ label-freeInGHashTable TransferNothing label = return ["unrefGHashTable " ++ label]+ <> label+freeInGHashTable TransferNothing label = return ["unrefGHashTable " <> label] -freeOut :: String -> CodeGen [String]-freeOut label = return ["freeMem " ++ label]+freeOut :: Text -> CodeGen [Text]+freeOut label = return ["freeMem " <> label] -- | Given an input argument to a C callable, and its label in the code, -- return the list of actions relevant to freeing the memory allocated -- for the argument (if appropriate, depending on the ownership -- transfer semantics of the callable).-freeInArg :: Arg -> String -> String -> ExcCodeGen [String]+freeInArg :: Arg -> Text -> Text -> ExcCodeGen [Text] freeInArg arg label len = do weAlloc <- isJust <$> requiresAlloc (argType arg) -- Arguments that we alloc ourselves do not need to be freed, they@@ -239,7 +239,7 @@ -- | Same thing as freeInArg, but called in case the call to C didn't -- succeed. We thus free everything we allocated in preparation for -- the call, including args that would have been transferred to C.-freeInArgOnError :: Arg -> String -> String -> ExcCodeGen [String]+freeInArgOnError :: Arg -> Text -> Text -> ExcCodeGen [Text] freeInArgOnError arg label len = case direction arg of DirectionIn -> freeInOnError (transfer arg) (argType arg) label len
src/GI/Type.hs view
@@ -42,7 +42,7 @@ | TGArray Type | TPtrArray Type | TByteArray- | TInterface String String+ | TInterface Text Text | TGList Type | TGSList Type | TGHash Type Type
src/GI/Util.hs view
@@ -1,60 +1,48 @@ module GI.Util- ( maybeWithCString- , getList- , toFlags- , split-- , prime- , unprime+ ( prime , parenthesize , padTo , withComment- ) where -import Foreign-import Foreign.C+ , ucFirst+ , lcFirst -import Data.List (unfoldr)+ , tshow+ , terror+ ) where -padTo n s = s ++ replicate (n - length s) ' '-withComment a b = padTo 40 a ++ "-- " ++ b+import Data.Monoid ((<>))+import Data.Char (toLower, toUpper)+import Data.Text (Text)+import qualified Data.Text as T -maybeWithCString :: Maybe String -> (CString -> IO a) -> IO a-maybeWithCString = maybe ($ nullPtr) withCString+padTo :: Int -> Text -> Text+padTo n s = s <> T.replicate (n - T.length s) " " -getList :: (a -> IO CInt) -> (a -> CInt -> IO b) -> a -> IO [b]-getList getN getOne x = do- n <- getN x- mapM (getOne x) [0..n - 1]+withComment :: Text -> Text -> Text+withComment a b = padTo 40 a <> "-- " <> b -toFlags :: Enum a => CInt -> [a]-toFlags n = loop n (sizeOf n * 8 - 1) -- Number of bits in the argument- where loop _ (-1) = []- loop n e =- let rest = loop n (e - 1)- in if testBit n e then toEnum (2 ^ e) : rest else rest+prime :: Text -> Text+prime = (<> "'") --- Splits a string separated by the given separator into a list of--- constituents. For example: split '.' "A.BC.D" = ["A", "BC", "D"]-split :: Char -> String -> [String]-split sep = unfoldr span'- where span' :: String -> Maybe (String, String)- span' [] = Nothing- span' s@(x:xs)- | x == sep = Just $ span (/= sep) xs- | otherwise = Just $ span (/= sep) s+parenthesize :: Text -> Text+parenthesize s = "(" <> s <> ")" -prime :: String -> String-prime = (++ "'")+-- | Construct the `Text` representation of a showable.+tshow :: Show a => a -> Text+tshow = T.pack . show --- Remove the prime at the end of the given string-unprime :: String -> String-unprime "" = error "Empty variable to unprime!"-unprime primed =- case last primed of- '\'' -> init primed- _ -> error $ primed ++ " is not primed!"+-- | Throw an error with the given `Text`.+terror :: Text -> a+terror = error . T.unpack -parenthesize :: String -> String-parenthesize s = "(" ++ s ++ ")"+-- | Capitalize the first character of the given string.+ucFirst :: Text -> Text+ucFirst "" = terror "ucFirst: empty text!"+ucFirst t = T.cons (toUpper $ T.head t) (T.tail t)++-- | Make the first character of the given string lowercase.+lcFirst :: Text -> Text+lcFirst "" = terror "lcFirst: empty string"+lcFirst t = T.cons (toLower $ T.head t) (T.tail t)
src/haskell-gi.hs view
@@ -1,7 +1,6 @@ module Main where #if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>)) import Data.Traversable (traverse) #endif import Control.Monad (forM_, when, (>=>))@@ -9,11 +8,10 @@ import Data.Char (toLower) import Data.Bool (bool)-import Data.List (intercalate)-import Data.Text (pack, unpack, Text)+import Data.Monoid ((<>))+import Data.Text (Text) -import System.Directory (createDirectoryIfMissing, doesFileExist)-import System.FilePath (splitDirectories, joinPath)+import System.Directory (doesFileExist) import System.Console.GetOpt import System.Exit import System.IO (hPutStr, hPutStrLn, stderr)@@ -29,20 +27,20 @@ import GI.API (loadGIRInfo, loadRawGIRInfo, GIRInfo(girAPIs, girNSName), Name, API) import GI.Cabal (cabalConfig, setupHs, genCabalProject)-import GI.Code (codeToString, genCode, evalCodeGen)+import GI.Code (genCode, evalCodeGen, transitiveModuleDeps, writeModuleTree, writeModuleCode, moduleCode, codeToText) import GI.Config (Config(..)) import GI.CodeGen (genModule)-import GI.Attributes (genAttributes, genAllAttributes)-import GI.OverloadedSignals (genSignalInstances, genOverloadedSignalConnectors)+import GI.Attributes (genAllAttributes)+import GI.OverloadedSignals (genOverloadedSignalConnectors) import GI.Overrides (Overrides, parseOverridesFile, nsChooseVersion, filterAPIsAndDeps) import GI.ProjectInfo (licenseText)-import GI.SymbolNaming (ucFirst)+import GI.Util (ucFirst) data Mode = GenerateCode | Dump | Attributes | Signals | Help data Options = Options { optMode :: Mode,- optOutput :: Maybe String,+ optOutputDir :: Maybe String, optOverridesFiles :: [String], optSearchPaths :: [String], optVerbose :: Bool,@@ -50,7 +48,7 @@ defaultOptions = Options { optMode = GenerateCode,- optOutput = Just "GI",+ optOutputDir = Nothing, optOverridesFiles = [], optSearchPaths = [], optVerbose = False,@@ -78,7 +76,7 @@ "OVERRIDES") "specify a file with overrides info", Option "O" ["output"] (ReqArg- (\arg opt -> opt {optOutput = Just arg}) "DIR")+ (\arg opt -> opt {optOutputDir = Just arg}) "DIR") "\tset the output directory", Option "s" ["search"] (ReqArg (\arg opt -> opt { optSearchPaths = arg : optSearchPaths opt }) "PATH")@@ -91,61 +89,47 @@ " -" ++ flag ++ "|--" ++ long ++ "\t" ++ desc ++ "\n" optAsLine _ = error "showHelp" -printGError = handle (gerrorMessage >=> putStrLn . unpack)--outputPath :: Options -> IO (String, String) -- modPrefix, dirPrefix-outputPath options =- case optOutput options of- Nothing -> return ("", ".")- Just dir -> do- createDirectoryIfMissing True dir- let prefix = intercalate "." (splitDirectories dir) ++ "."- return (prefix, dir)---- | Load the given API and dependencies, filtering them in the process.-loadFilteredAPI :: Bool -> Overrides -> [FilePath] -> Text- -> IO (M.Map Name API, M.Map Name API)-loadFilteredAPI verbose ovs extraPaths name = do- (gir, girDeps) <- loadGIRInfo verbose name Nothing extraPaths- return $ filterAPIsAndDeps ovs gir girDeps+printGError = handle (gerrorMessage >=> putStrLn . T.unpack) -- | Load a dependency without further postprocessing.-loadRawAPIs :: Bool -> [FilePath] -> Text -> IO [(Name, API)]-loadRawAPIs verbose extraPaths name = do- gir <- loadRawGIRInfo verbose name Nothing extraPaths+loadRawAPIs :: Bool -> Overrides -> [FilePath] -> Text -> IO [(Name, API)]+loadRawAPIs verbose ovs extraPaths name = do+ let version = M.lookup name (nsChooseVersion ovs)+ gir <- loadRawGIRInfo verbose name version extraPaths return (girAPIs gir) -- Generate all generic accessor functions ("_label", for example). genGenericAttrs :: Options -> Overrides -> [Text] -> [FilePath] -> IO () genGenericAttrs options ovs modules extraPaths = do- apis <- mapM (loadRawAPIs (optVerbose options) extraPaths) modules+ apis <- mapM (loadRawAPIs (optVerbose options) ovs extraPaths) modules let allAPIs = M.unions (map M.fromList apis) cfg = Config {modName = Nothing, verbose = optVerbose options, overrides = ovs}- (modPrefix, dirPrefix) <- outputPath options- putStrLn $ "\t* Generating " ++ modPrefix ++ "Properties"- (_, code) <- genCode cfg allAPIs (genAllAttributes (M.toList allAPIs) modPrefix)- writeFile (joinPath [dirPrefix, "Properties.hs"]) $ codeToString code+ putStrLn $ "\t* Generating GI.Properties"+ m <- genCode cfg allAPIs ["GI", "Properties"] (genAllAttributes (M.toList allAPIs))+ _ <- writeModuleCode (optVerbose options) (optOutputDir options) m+ return () -- Generate generic signal connectors ("Clicked", "Activate", ...) genGenericConnectors :: Options -> Overrides -> [Text] -> [FilePath] -> IO () genGenericConnectors options ovs modules extraPaths = do- apis <- mapM (loadRawAPIs (optVerbose options) extraPaths) modules+ apis <- mapM (loadRawAPIs (optVerbose options) ovs extraPaths) modules let allAPIs = M.unions (map M.fromList apis) cfg = Config {modName = Nothing, verbose = optVerbose options, overrides = ovs}- (modPrefix, dirPrefix) <- outputPath options- putStrLn $ "\t* Generating " ++ modPrefix ++ "Signals"- (_, code) <- genCode cfg allAPIs (genOverloadedSignalConnectors (M.toList allAPIs) modPrefix)- writeFile (joinPath [dirPrefix, "Signals.hs"]) $ codeToString code+ putStrLn $ "\t* Generating GI.Signals"+ m <- genCode cfg allAPIs ["GI", "Signals"] (genOverloadedSignalConnectors (M.toList allAPIs))+ _ <- writeModuleCode (optVerbose options) (optOutputDir options) m+ return () -- Generate the code for the given module, and return the dependencies -- for this module.-processMod :: Options -> Overrides -> [FilePath] -> String -> IO ()+processMod :: Options -> Overrides -> [FilePath] -> Text -> IO () processMod options ovs extraPaths name = do- (gir, girDeps) <- loadGIRInfo (optVerbose options) (T.pack name) Nothing extraPaths+ let version = M.lookup name (nsChooseVersion ovs)+ (gir, girDeps) <- loadGIRInfo (optVerbose options) name version extraPaths let (apis, deps) = filterAPIsAndDeps ovs gir girDeps allAPIs = M.union apis deps @@ -153,56 +137,47 @@ verbose = optVerbose options, overrides = ovs} nm = ucFirst name-- (modPrefix, dirPrefix) <- outputPath options-- putStrLn $ "\t* Generating " ++ modPrefix ++ nm- (modDeps, code) <- genCode cfg allAPIs (genModule name (M.toList apis) modPrefix)- writeFile (joinPath [dirPrefix, nm ++ ".hs"]) $- codeToString code-- putStrLn $ "\t\t+ " ++ modPrefix ++ nm ++ "Attributes"- (attrDeps, attrCode) <- genCode cfg allAPIs (genAttributes name (M.toList apis) modPrefix)- writeFile (joinPath [dirPrefix, nm ++ "Attributes.hs"]) $- codeToString attrCode+ mp = T.unpack . ("GI." <>) - putStrLn $ "\t\t+ " ++ modPrefix ++ nm ++ "Signals"- (sigDeps, signalCode) <- genCode cfg allAPIs (genSignalInstances name (M.toList apis) modPrefix)- writeFile (joinPath [dirPrefix, nm ++ "Signals.hs"]) $- codeToString signalCode+ putStrLn $ "\t* Generating " ++ mp nm+ m <- genCode cfg allAPIs ["GI", nm] (genModule apis)+ let modDeps = transitiveModuleDeps m+ moduleList <- writeModuleTree (optVerbose options) (optOutputDir options) m when (optCabal options) $ do- let cabal = "gi-" ++ map toLower nm ++ ".cabal"+ let cabal = "gi-" ++ map toLower (T.unpack nm) ++ ".cabal" fname <- doesFileExist cabal >>= bool (return cabal) (putStrLn (cabal ++ " exists, writing " ++ cabal ++ ".new instead") >> return (cabal ++ ".new")) putStrLn $ "\t\t+ " ++ fname- let usedDeps = S.delete name -- The module is not a dep of itself- $ S.unions [modDeps, attrDeps, sigDeps]+ -- The module is not a dep of itself+ let usedDeps = S.delete name modDeps+ -- We only list as dependencies in the cabal file the -- dependencies that we use, disregarding what the .gir file says.- actualDeps = filter ((`S.member` usedDeps) . T.unpack . girNSName) girDeps- (err, cabalCode) <- evalCodeGen cfg allAPIs (genCabalProject gir actualDeps modPrefix)+ actualDeps = filter ((`S.member` usedDeps) . girNSName) girDeps+ (err, m) <- evalCodeGen cfg allAPIs [] (genCabalProject gir actualDeps moduleList) case err of Nothing -> do- writeFile fname (codeToString cabalCode)+ TIO.writeFile fname (codeToText (moduleCode m)) putStrLn "\t\t+ cabal.config"- writeFile "cabal.config" (T.unpack cabalConfig)+ TIO.writeFile "cabal.config" cabalConfig putStrLn "\t\t+ Setup.hs"- writeFile "Setup.hs" (T.unpack setupHs)+ TIO.writeFile "Setup.hs" setupHs putStrLn "\t\t+ LICENSE"- writeFile "LICENSE" (licenseText)+ TIO.writeFile "LICENSE" licenseText Just msg -> putStrLn $ "ERROR: could not generate " ++ fname- ++ "\nError was: " ++ msg+ ++ "\nError was: " ++ T.unpack msg -dump :: Options -> Overrides -> String -> IO ()+dump :: Options -> Overrides -> Text -> IO () dump options ovs name = do- (doc, _) <- loadGIRInfo (optVerbose options) (pack name) (pack <$> M.lookup name (nsChooseVersion ovs)) (optSearchPaths options)+ let version = M.lookup name (nsChooseVersion ovs)+ (doc, _) <- loadGIRInfo (optVerbose options) name version (optSearchPaths options) mapM_ (putStrLn . ppShow) (girAPIs doc) -process :: Options -> [String] -> IO ()+process :: Options -> [Text] -> IO () process options names = do let extraPaths = optSearchPaths options configs <- traverse TIO.readFile (optOverridesFiles options)@@ -214,17 +189,13 @@ Right ovs -> case optMode options of GenerateCode -> forM_ names (processMod options ovs extraPaths)- Attributes -> genGenericAttrs options ovs (map T.pack names) extraPaths- Signals -> genGenericConnectors options ovs (map T.pack names) extraPaths+ Attributes -> genGenericAttrs options ovs names extraPaths+ Signals -> genGenericConnectors options ovs names extraPaths Dump -> forM_ names (dump options ovs) Help -> putStr showHelp -foreign import ccall "g_type.h g_type_init"- g_type_init :: IO ()- main :: IO () main = printGError $ do- g_type_init -- Initialize GLib's type system. args <- getArgs let (actions, nonOptions, errors) = getOpt RequireOrder optDescrs args options = foldl (.) id actions defaultOptions@@ -237,7 +208,7 @@ case nonOptions of [] -> failWithUsage- names -> process options names+ names -> process options (map T.pack names) where failWithUsage = do hPutStrLn stderr "usage: haskell-gi [options] module1 [module2 [...]]"