{-# LANGUAGE ViewPatterns #-}
module Data.GI.CodeGen.Overrides
    ( Overrides(pkgConfigMap, cabalPkgVersion, nsChooseVersion, girFixups,
                onlineDocsMap)
    , parseOverrides
    , filterAPIsAndDeps
    ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
import Data.Traversable (traverse)
#endif

import Control.Monad.Except
import Control.Monad.State
import Control.Monad.Writer (WriterT, execWriterT, tell)

import Data.Maybe (isJust)
import qualified Data.Map as M
import Data.Semigroup as Sem
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Text (Text)
import qualified Data.Version as V

import Text.ParserCombinators.ReadP (readP_to_S)

import qualified System.Info as SI

import Data.GI.CodeGen.API
import qualified Text.XML as XML
import Data.GI.CodeGen.PkgConfig (tryPkgConfig)
import Data.GI.CodeGen.Util (tshow, utf8ReadFile)
import Data.GI.GIR.XMLUtils (xmlLocalName, xmlNSName,
                             GIRXMLNamespace(CGIRNS, GLibGIRNS, CoreGIRNS))

data Overrides = Overrides {
      -- | Ignored elements of a given API.
      Overrides -> Map Name (Set Text)
ignoredElems    :: M.Map Name (S.Set Text),
      -- | Ignored APIs (all elements in this API will just be discarded).
      Overrides -> Set Name
ignoredAPIs     :: S.Set Name,
      -- | Structs for which accessors should not be auto-generated.
      Overrides -> Set Name
sealedStructs   :: S.Set Name,
      -- | Explicit calloc\/copy\/free for structs/unions.
      Overrides -> Map Name AllocationInfo
allocInfo       :: M.Map Name AllocationInfo,
      -- | Mapping from GObject Introspection namespaces to pkg-config
      Overrides -> Map Text Text
pkgConfigMap    :: M.Map Text Text,
      -- | Version number for the generated .cabal package.
      Overrides -> Maybe Text
cabalPkgVersion :: Maybe Text,
      -- | Prefered version of the namespace.
      Overrides -> Map Text Text
nsChooseVersion :: M.Map Text Text,
      -- | Fixups for the GIR data.
      Overrides -> [GIRRule]
girFixups       :: [GIRRule],
      -- | Known places where to find the C docs.
      Overrides -> Map Text Text
onlineDocsMap   :: M.Map Text Text
} deriving (Int -> Overrides -> ShowS
[Overrides] -> ShowS
Overrides -> String
(Int -> Overrides -> ShowS)
-> (Overrides -> String)
-> ([Overrides] -> ShowS)
-> Show Overrides
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Overrides] -> ShowS
$cshowList :: [Overrides] -> ShowS
show :: Overrides -> String
$cshow :: Overrides -> String
showsPrec :: Int -> Overrides -> ShowS
$cshowsPrec :: Int -> Overrides -> ShowS
Show)

-- | Construct the generic config for a module.
defaultOverrides :: Overrides
defaultOverrides :: Overrides
defaultOverrides = Overrides :: Map Name (Set Text)
-> Set Name
-> Set Name
-> Map Name AllocationInfo
-> Map Text Text
-> Maybe Text
-> Map Text Text
-> [GIRRule]
-> Map Text Text
-> Overrides
Overrides {
                     ignoredElems :: Map Name (Set Text)
ignoredElems    = Map Name (Set Text)
forall k a. Map k a
M.empty,
                     ignoredAPIs :: Set Name
ignoredAPIs     = Set Name
forall a. Set a
S.empty,
                     sealedStructs :: Set Name
sealedStructs   = Set Name
forall a. Set a
S.empty,
                     allocInfo :: Map Name AllocationInfo
allocInfo       = Map Name AllocationInfo
forall k a. Map k a
M.empty,
                     pkgConfigMap :: Map Text Text
pkgConfigMap    = Map Text Text
forall k a. Map k a
M.empty,
                     cabalPkgVersion :: Maybe Text
cabalPkgVersion = Maybe Text
forall a. Maybe a
Nothing,
                     nsChooseVersion :: Map Text Text
nsChooseVersion = Map Text Text
forall k a. Map k a
M.empty,
                     girFixups :: [GIRRule]
girFixups       = [],
                     onlineDocsMap :: Map Text Text
onlineDocsMap   = Map Text Text
forall k a. Map k a
M.empty
                   }

-- | There is a sensible notion of zero and addition of Overridess,
-- encode this so that we can view the parser as a writer monad of
-- configs.
instance Monoid Overrides where
  mempty :: Overrides
mempty = Overrides
defaultOverrides
#if !MIN_VERSION_base(4,11,0)
  mappend = concatOverrides
#endif

-- | There is a sensible notion of zero and addition of Overridess,
-- encode this so that we can view the parser as a writer monad of
-- configs.
instance Sem.Semigroup Overrides where
  <> :: Overrides -> Overrides -> Overrides
(<>) = Overrides -> Overrides -> Overrides
concatOverrides

-- | Addition of overrides is meaningful.
concatOverrides :: Overrides -> Overrides -> Overrides
concatOverrides :: Overrides -> Overrides -> Overrides
concatOverrides a :: Overrides
a b :: Overrides
b = Overrides :: Map Name (Set Text)
-> Set Name
-> Set Name
-> Map Name AllocationInfo
-> Map Text Text
-> Maybe Text
-> Map Text Text
-> [GIRRule]
-> Map Text Text
-> Overrides
Overrides {
      ignoredAPIs :: Set Name
ignoredAPIs = Overrides -> Set Name
ignoredAPIs Overrides
a Set Name -> Set Name -> Set Name
forall a. Semigroup a => a -> a -> a
<> Overrides -> Set Name
ignoredAPIs Overrides
b,
      sealedStructs :: Set Name
sealedStructs = Overrides -> Set Name
sealedStructs Overrides
a Set Name -> Set Name -> Set Name
forall a. Semigroup a => a -> a -> a
<> Overrides -> Set Name
sealedStructs Overrides
b,
      allocInfo :: Map Name AllocationInfo
allocInfo = Overrides -> Map Name AllocationInfo
allocInfo Overrides
a Map Name AllocationInfo
-> Map Name AllocationInfo -> Map Name AllocationInfo
forall a. Semigroup a => a -> a -> a
<> Overrides -> Map Name AllocationInfo
allocInfo Overrides
b,
      ignoredElems :: Map Name (Set Text)
ignoredElems = (Set Text -> Set Text -> Set Text)
-> Map Name (Set Text)
-> Map Name (Set Text)
-> Map Name (Set Text)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
S.union (Overrides -> Map Name (Set Text)
ignoredElems Overrides
a) (Overrides -> Map Name (Set Text)
ignoredElems Overrides
b),
      pkgConfigMap :: Map Text Text
pkgConfigMap = Overrides -> Map Text Text
pkgConfigMap Overrides
a Map Text Text -> Map Text Text -> Map Text Text
forall a. Semigroup a => a -> a -> a
<> Overrides -> Map Text Text
pkgConfigMap Overrides
b,
      cabalPkgVersion :: Maybe Text
cabalPkgVersion = if Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Overrides -> Maybe Text
cabalPkgVersion Overrides
b)
                        then Overrides -> Maybe Text
cabalPkgVersion Overrides
b
                        else Overrides -> Maybe Text
cabalPkgVersion Overrides
a,
      nsChooseVersion :: Map Text Text
nsChooseVersion = Overrides -> Map Text Text
nsChooseVersion Overrides
a Map Text Text -> Map Text Text -> Map Text Text
forall a. Semigroup a => a -> a -> a
<> Overrides -> Map Text Text
nsChooseVersion Overrides
b,
      girFixups :: [GIRRule]
girFixups = Overrides -> [GIRRule]
girFixups Overrides
a [GIRRule] -> [GIRRule] -> [GIRRule]
forall a. Semigroup a => a -> a -> a
<> Overrides -> [GIRRule]
girFixups Overrides
b,
      onlineDocsMap :: Map Text Text
onlineDocsMap = Overrides -> Map Text Text
onlineDocsMap Overrides
a Map Text Text -> Map Text Text -> Map Text Text
forall a. Semigroup a => a -> a -> a
<> Overrides -> Map Text Text
onlineDocsMap Overrides
b
    }

-- | The state of the overrides parser.
data ParserState = ParserState {
      ParserState -> Maybe Text
currentNS :: Maybe Text   -- ^ The current namespace.
    , ParserState -> [Bool]
flags     :: [Bool] -- ^ The contents of the override file will
                          -- be ignored if there is any `False` value
                          -- here. @if@ primitive push (prepend)
                          -- values here, @endif@ pop them.
    } deriving (Int -> ParserState -> ShowS
[ParserState] -> ShowS
ParserState -> String
(Int -> ParserState -> ShowS)
-> (ParserState -> String)
-> ([ParserState] -> ShowS)
-> Show ParserState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParserState] -> ShowS
$cshowList :: [ParserState] -> ShowS
show :: ParserState -> String
$cshow :: ParserState -> String
showsPrec :: Int -> ParserState -> ShowS
$cshowsPrec :: Int -> ParserState -> ShowS
Show)

-- | Default, empty, parser state.
emptyParserState :: ParserState
emptyParserState :: ParserState
emptyParserState = ParserState :: Maybe Text -> [Bool] -> ParserState
ParserState {
                     currentNS :: Maybe Text
currentNS = Maybe Text
forall a. Maybe a
Nothing
                   , flags :: [Bool]
flags = []
                   }

-- | Get the current namespace.
getNS :: Parser (Maybe Text)
getNS :: Parser (Maybe Text)
getNS = ParserState -> Maybe Text
currentNS (ParserState -> Maybe Text)
-> WriterT
     Overrides (StateT ParserState (ExceptT Text IO)) ParserState
-> Parser (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterT
  Overrides (StateT ParserState (ExceptT Text IO)) ParserState
forall s (m :: * -> *). MonadState s m => m s
get

-- | Run the given parser only if the flags can be satisfied.
withFlags :: Parser () -> Parser ()
withFlags :: Parser () -> Parser ()
withFlags p :: Parser ()
p = do
  [Bool]
fs <- ParserState -> [Bool]
flags (ParserState -> [Bool])
-> WriterT
     Overrides (StateT ParserState (ExceptT Text IO)) ParserState
-> WriterT Overrides (StateT ParserState (ExceptT Text IO)) [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterT
  Overrides (StateT ParserState (ExceptT Text IO)) ParserState
forall s (m :: * -> *). MonadState s m => m s
get
  if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
fs
  then Parser ()
p
  else () -> Parser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | We have a bit of context (the current namespace), and can fail,
-- encode this in a monad.
type Parser a = WriterT Overrides (StateT ParserState (ExceptT Text IO)) a

-- | Parse the given overrides, filling in the configuration as
-- needed. In case the parsing fails we return a description of the
-- error instead.
parseOverrides :: Text -> IO (Either Text Overrides)
parseOverrides :: Text -> IO (Either Text Overrides)
parseOverrides overrides :: Text
overrides = do
  ExceptT Text IO Overrides -> IO (Either Text Overrides)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO Overrides -> IO (Either Text Overrides))
-> ExceptT Text IO Overrides -> IO (Either Text Overrides)
forall a b. (a -> b) -> a -> b
$ (StateT ParserState (ExceptT Text IO) Overrides
 -> ParserState -> ExceptT Text IO Overrides)
-> ParserState
-> StateT ParserState (ExceptT Text IO) Overrides
-> ExceptT Text IO Overrides
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT ParserState (ExceptT Text IO) Overrides
-> ParserState -> ExceptT Text IO Overrides
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ParserState
emptyParserState (StateT ParserState (ExceptT Text IO) Overrides
 -> ExceptT Text IO Overrides)
-> StateT ParserState (ExceptT Text IO) Overrides
-> ExceptT Text IO Overrides
forall a b. (a -> b) -> a -> b
$ WriterT Overrides (StateT ParserState (ExceptT Text IO)) [()]
-> StateT ParserState (ExceptT Text IO) Overrides
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT Overrides (StateT ParserState (ExceptT Text IO)) [()]
 -> StateT ParserState (ExceptT Text IO) Overrides)
-> WriterT Overrides (StateT ParserState (ExceptT Text IO)) [()]
-> StateT ParserState (ExceptT Text IO) Overrides
forall a b. (a -> b) -> a -> b
$
    (Text -> Parser ())
-> [Text]
-> WriterT Overrides (StateT ParserState (ExceptT Text IO)) [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Text -> Parser ()
parseOneLine (Text -> Parser ()) -> (Text -> Text) -> Text -> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip) (Text -> [Text]
T.lines Text
overrides)

-- | Parse a single line of the config file, modifying the
-- configuration as appropriate.
parseOneLine :: Text -> Parser ()
-- Empty lines
parseOneLine :: Text -> Parser ()
parseOneLine line :: Text
line | Text -> Bool
T.null Text
line = () -> Parser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
-- Comments
parseOneLine (Text -> Text -> Maybe Text
T.stripPrefix "#" -> Just _) = () -> Parser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
parseOneLine (Text -> Text -> Maybe Text
T.stripPrefix "namespace " -> Just ns :: Text
ns) =
    Parser () -> Parser ()
withFlags (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ (ParserState -> ParserState) -> Parser ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\s :: ParserState
s -> ParserState
s {currentNS :: Maybe Text
currentNS = (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> (Text -> Text) -> Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip) Text
ns})
parseOneLine (Text -> Text -> Maybe Text
T.stripPrefix "ignore " -> Just ign :: Text
ign) =
    Parser () -> Parser ()
withFlags (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ Parser (Maybe Text)
getNS Parser (Maybe Text) -> (Maybe Text -> Parser ()) -> Parser ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Text -> Parser ()
parseIgnore Text
ign
parseOneLine (Text -> Text -> Maybe Text
T.stripPrefix "seal " -> Just s :: Text
s) =
    Parser () -> Parser ()
withFlags (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ Parser (Maybe Text)
getNS Parser (Maybe Text) -> (Maybe Text -> Parser ()) -> Parser ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Text -> Parser ()
parseSeal Text
s
parseOneLine (Text -> Text -> Maybe Text
T.stripPrefix "alloc-info " -> Just s :: Text
s) =
    Parser () -> Parser ()
withFlags (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ Parser (Maybe Text)
getNS Parser (Maybe Text) -> (Maybe Text -> Parser ()) -> Parser ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Text -> Parser ()
parseAllocInfo Text
s
parseOneLine (Text -> Text -> Maybe Text
T.stripPrefix "pkg-config-name " -> Just s :: Text
s) =
    Parser () -> Parser ()
withFlags (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ Text -> Parser ()
parsePkgConfigName Text
s
parseOneLine (Text -> Text -> Maybe Text
T.stripPrefix "cabal-pkg-version " -> Just s :: Text
s) =
    Parser () -> Parser ()
withFlags (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ Text -> Parser ()
parseCabalPkgVersion Text
s
parseOneLine (Text -> Text -> Maybe Text
T.stripPrefix "namespace-version " -> Just s :: Text
s) =
    Parser () -> Parser ()
withFlags (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ Text -> Parser ()
parseNsVersion Text
s
parseOneLine (Text -> Text -> Maybe Text
T.stripPrefix "set-attr " -> Just s :: Text
s) =
    Parser () -> Parser ()
withFlags (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ Text -> Parser ()
parseSetAttr Text
s
parseOneLine (Text -> Text -> Maybe Text
T.stripPrefix "add-node " -> Just s :: Text
s) =
    Parser () -> Parser ()
withFlags (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ Text -> Parser ()
parseAdd Text
s
parseOneLine (Text -> Text -> Maybe Text
T.stripPrefix "delete-node " -> Just s :: Text
s) =
    Parser () -> Parser ()
withFlags (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ Text -> Parser ()
parseDelete Text
s
parseOneLine (Text -> Text -> Maybe Text
T.stripPrefix "C-docs-url " -> Just u :: Text
u) =
    Parser () -> Parser ()
withFlags (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ Text -> Parser ()
parseDocsUrl Text
u
parseOneLine (Text -> Text -> Maybe Text
T.stripPrefix "if " -> Just s :: Text
s) = Text -> Parser ()
parseIf Text
s
parseOneLine (Text -> Text -> Maybe Text
T.stripPrefix "endif" -> Just s :: Text
s) = Text -> Parser ()
parseEndif Text
s
parseOneLine (Text -> Text -> Maybe Text
T.stripPrefix "include " -> Just s :: Text
s) = Text -> Parser ()
parseInclude Text
s
parseOneLine l :: Text
l = Text -> Parser ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> Parser ()) -> Text -> Parser ()
forall a b. (a -> b) -> a -> b
$ "Could not understand \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\"."

-- | Ignored elements.
parseIgnore :: Text -> Maybe Text -> Parser ()
parseIgnore :: Text -> Maybe Text -> Parser ()
parseIgnore _ Nothing =
    Text -> Parser ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError "'ignore' requires a namespace to be defined first."
parseIgnore (Text -> [Text]
T.words -> [Text -> Text -> [Text]
T.splitOn "." -> [api :: Text
api,elem :: Text
elem]]) (Just ns :: Text
ns) =
    Overrides -> Parser ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Overrides -> Parser ()) -> Overrides -> Parser ()
forall a b. (a -> b) -> a -> b
$ Overrides
defaultOverrides {ignoredElems :: Map Name (Set Text)
ignoredElems = Name -> Set Text -> Map Name (Set Text)
forall k a. k -> a -> Map k a
M.singleton (Text -> Text -> Name
Name Text
ns Text
api)
                                         (Text -> Set Text
forall a. a -> Set a
S.singleton Text
elem)}
parseIgnore (Text -> [Text]
T.words -> [Text -> Text -> [Text]
T.splitOn "." -> [api :: Text
api]]) (Just ns :: Text
ns) =
    Overrides -> Parser ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Overrides -> Parser ()) -> Overrides -> Parser ()
forall a b. (a -> b) -> a -> b
$ Overrides
defaultOverrides {ignoredAPIs :: Set Name
ignoredAPIs = Name -> Set Name
forall a. a -> Set a
S.singleton (Text -> Text -> Name
Name Text
ns Text
api)}
parseIgnore ignore :: Text
ignore _ =
    Text -> Parser ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("Ignore syntax is of the form \"ignore API.elem\" with '.elem' optional.\nGot \"ignore " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ignore Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" instead.")

-- | Sealed structures.
parseSeal :: Text -> Maybe Text -> Parser ()
parseSeal :: Text -> Maybe Text -> Parser ()
parseSeal _ Nothing = Text -> Parser ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError "'seal' requires a namespace to be defined first."
parseSeal (Text -> [Text]
T.words -> [s :: Text
s]) (Just ns :: Text
ns) = Overrides -> Parser ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Overrides -> Parser ()) -> Overrides -> Parser ()
forall a b. (a -> b) -> a -> b
$
    Overrides
defaultOverrides {sealedStructs :: Set Name
sealedStructs = Name -> Set Name
forall a. a -> Set a
S.singleton (Text -> Text -> Name
Name Text
ns Text
s)}
parseSeal seal :: Text
seal _ =
    Text -> Parser ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("seal syntax is of the form \"seal name\".\nGot \"seal "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
seal Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" instead.")

-- | Explicit allocation info for wrapped pointers.
parseAllocInfo :: Text -> Maybe Text -> Parser ()
parseAllocInfo :: Text -> Maybe Text -> Parser ()
parseAllocInfo _ Nothing = Text -> Parser ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError "'alloc-info' requires a namespace to be defined first."
parseAllocInfo (Text -> [Text]
T.words -> (n :: Text
n:ops :: [Text]
ops)) (Just ns :: Text
ns) = do
  [(Text, Text)]
parsedOps <- (Text
 -> WriterT
      Overrides (StateT ParserState (ExceptT Text IO)) (Text, Text))
-> [Text]
-> WriterT
     Overrides (StateT ParserState (ExceptT Text IO)) [(Text, Text)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text
-> WriterT
     Overrides (StateT ParserState (ExceptT Text IO)) (Text, Text)
parseKeyValuePair [Text]
ops
  AllocationInfo
info <- (AllocationInfo
 -> (Text, Text)
 -> WriterT
      Overrides (StateT ParserState (ExceptT Text IO)) AllocationInfo)
-> AllocationInfo
-> [(Text, Text)]
-> WriterT
     Overrides (StateT ParserState (ExceptT Text IO)) AllocationInfo
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM AllocationInfo
-> (Text, Text)
-> WriterT
     Overrides (StateT ParserState (ExceptT Text IO)) AllocationInfo
applyOp AllocationInfo
unknownAllocationInfo [(Text, Text)]
parsedOps
  Overrides -> Parser ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Overrides -> Parser ()) -> Overrides -> Parser ()
forall a b. (a -> b) -> a -> b
$ Overrides
defaultOverrides {allocInfo :: Map Name AllocationInfo
allocInfo = Name -> AllocationInfo -> Map Name AllocationInfo
forall k a. k -> a -> Map k a
M.singleton (Text -> Text -> Name
Name Text
ns Text
n) AllocationInfo
info}
  where applyOp :: AllocationInfo -> (Text, Text) -> Parser AllocationInfo
        applyOp :: AllocationInfo
-> (Text, Text)
-> WriterT
     Overrides (StateT ParserState (ExceptT Text IO)) AllocationInfo
applyOp a :: AllocationInfo
a ("calloc", f :: Text
f) = AllocationInfo
-> WriterT
     Overrides (StateT ParserState (ExceptT Text IO)) AllocationInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (AllocationInfo
a {allocCalloc :: AllocationOp
allocCalloc = Text -> AllocationOp
AllocationOp Text
f})
        applyOp a :: AllocationInfo
a ("copy", f :: Text
f) = AllocationInfo
-> WriterT
     Overrides (StateT ParserState (ExceptT Text IO)) AllocationInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (AllocationInfo
a {allocCopy :: AllocationOp
allocCopy = Text -> AllocationOp
AllocationOp Text
f})
        applyOp a :: AllocationInfo
a ("free", f :: Text
f) = AllocationInfo
-> WriterT
     Overrides (StateT ParserState (ExceptT Text IO)) AllocationInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (AllocationInfo
a {allocFree :: AllocationOp
allocFree = Text -> AllocationOp
AllocationOp Text
f})
        applyOp _ (op :: Text
op, _) = Text
-> WriterT
     Overrides (StateT ParserState (ExceptT Text IO)) AllocationInfo
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("Unknown alloc op \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
op Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\".")
parseAllocInfo info :: Text
info _ =
    Text -> Parser ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("alloc-info syntax is of the form "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\"alloc-info name calloc copy free\", with \"-\" meaning "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "a masked operation. Got \"alloc-info " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
info
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" instead.")

-- | Parse a explicit key=value pair into a (key, value) tuple.
parseKeyValuePair :: Text -> Parser (Text, Text)
parseKeyValuePair :: Text
-> WriterT
     Overrides (StateT ParserState (ExceptT Text IO)) (Text, Text)
parseKeyValuePair p :: Text
p =
    case Text -> Text -> [Text]
T.splitOn "=" Text
p of
      [k :: Text
k,v :: Text
v] -> (Text, Text)
-> WriterT
     Overrides (StateT ParserState (ExceptT Text IO)) (Text, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
k, Text
v)
      _ -> Text
-> WriterT
     Overrides (StateT ParserState (ExceptT Text IO)) (Text, Text)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("Could not parse \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\"as a \"key=value\" pair.")

-- | Mapping from GObject Introspection namespaces to pkg-config.
parsePkgConfigName :: Text -> Parser ()
parsePkgConfigName :: Text -> Parser ()
parsePkgConfigName (Text -> [Text]
T.words -> [gi :: Text
gi,pc :: Text
pc]) = Overrides -> Parser ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Overrides -> Parser ()) -> Overrides -> Parser ()
forall a b. (a -> b) -> a -> b
$
    Overrides
defaultOverrides {pkgConfigMap :: Map Text Text
pkgConfigMap =
                          Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
M.singleton (Text -> Text
T.toLower Text
gi) Text
pc}
parsePkgConfigName t :: Text
t =
    Text -> Parser ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("pkg-config-name syntax is of the form\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                "\t\"pkg-config-name gi-namespace pk-name\"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                "Got \"pkg-config-name " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" instead.")

-- | Choose a preferred namespace version to load.
parseNsVersion :: Text -> Parser ()
parseNsVersion :: Text -> Parser ()
parseNsVersion (Text -> [Text]
T.words -> [ns :: Text
ns,version :: Text
version]) = Overrides -> Parser ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Overrides -> Parser ()) -> Overrides -> Parser ()
forall a b. (a -> b) -> a -> b
$
    Overrides
defaultOverrides {nsChooseVersion :: Map Text Text
nsChooseVersion =
                          Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
M.singleton Text
ns Text
version}
parseNsVersion t :: Text
t =
    Text -> Parser ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("namespace-version syntax is of the form\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                "\t\"namespace-version namespace version\"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                "Got \"namespace-version " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" instead.")

-- | Specifying the cabal package version by hand.
parseCabalPkgVersion :: Text -> Parser ()
parseCabalPkgVersion :: Text -> Parser ()
parseCabalPkgVersion (Text -> [Text]
T.words -> [version :: Text
version]) = Overrides -> Parser ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Overrides -> Parser ()) -> Overrides -> Parser ()
forall a b. (a -> b) -> a -> b
$
    Overrides
defaultOverrides {cabalPkgVersion :: Maybe Text
cabalPkgVersion = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
version}
parseCabalPkgVersion t :: Text
t =
    Text -> Parser ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("cabal-pkg-version syntax is of the form\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
               "\t\"cabal-pkg-version version\"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
               "Got \"cabal-pkg-version " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" instead.")

-- | Set a given attribute in the GIR file.
parseSetAttr :: Text -> Parser ()
parseSetAttr :: Text -> Parser ()
parseSetAttr (Text -> [Text]
T.words -> [path :: Text
path, attr :: Text
attr, newVal :: Text
newVal]) = do
  GIRPath
pathSpec <- Text -> Parser GIRPath
parsePathSpec Text
path
  Name
parsedAttr <- Text -> Parser Name
parseXMLName Text
attr
  Overrides -> Parser ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Overrides -> Parser ()) -> Overrides -> Parser ()
forall a b. (a -> b) -> a -> b
$ Overrides
defaultOverrides {girFixups :: [GIRRule]
girFixups =
                           [(GIRPath, Name) -> Text -> GIRRule
GIRSetAttr (GIRPath
pathSpec, Name
parsedAttr) Text
newVal]}
parseSetAttr t :: Text
t =
    Text -> Parser ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("set-attr syntax is of the form\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
               "\t\"set-attr nodePath attrName newValue\"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
               "Got \"set-attr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" instead.")

-- | Add the given child node to all nodes matching the path.
parseAdd :: Text -> Parser ()
parseAdd :: Text -> Parser ()
parseAdd (Text -> [Text]
T.words -> [path :: Text
path, name :: Text
name]) = do
  GIRPath
pathSpec <- Text -> Parser GIRPath
parsePathSpec Text
path
  Name
parsedName <- Text -> Parser Name
parseXMLName Text
name
  Overrides -> Parser ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Overrides -> Parser ()) -> Overrides -> Parser ()
forall a b. (a -> b) -> a -> b
$ Overrides
defaultOverrides {girFixups :: [GIRRule]
girFixups = [GIRPath -> Name -> GIRRule
GIRAddNode GIRPath
pathSpec Name
parsedName]}
parseAdd t :: Text
t =
    Text -> Parser ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("add-node syntax is of the form\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
               "\t\"add-node nodePath newName\"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
               "Got \"add-node " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" instead.")

-- | Delete all nodes matching the given path.
parseDelete :: Text -> Parser ()
parseDelete :: Text -> Parser ()
parseDelete (Text -> [Text]
T.words -> [path :: Text
path]) = do
  GIRPath
pathSpec <- Text -> Parser GIRPath
parsePathSpec Text
path
  Overrides -> Parser ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Overrides -> Parser ()) -> Overrides -> Parser ()
forall a b. (a -> b) -> a -> b
$ Overrides
defaultOverrides {girFixups :: [GIRRule]
girFixups = [GIRPath -> GIRRule
GIRDeleteNode GIRPath
pathSpec]}
parseDelete t :: Text
t =
    Text -> Parser ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("delete-node syntax is of the form\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
               "\t\"delete-node nodePath\"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
               "Got \"delete-node " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" instead.")

-- | Parse a documentation URL for the given module.
parseDocsUrl :: Text -> Parser ()
parseDocsUrl :: Text -> Parser ()
parseDocsUrl (Text -> [Text]
T.words -> [ns :: Text
ns, url :: Text
url]) = do
  Overrides -> Parser ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Overrides -> Parser ()) -> Overrides -> Parser ()
forall a b. (a -> b) -> a -> b
$ Overrides
defaultOverrides { onlineDocsMap :: Map Text Text
onlineDocsMap = Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
M.singleton Text
ns Text
url }
parseDocsUrl t :: Text
t =
  Text -> Parser ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("C-docs-url syntax of of the form\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
              "\t\"C-docs-url namespace url\"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
              "Got \"C-docs-url " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" instead.")

-- | Parse a path specification, which is of the form
-- "nodeSpec1/nodeSpec2/../nodeSpecN", where nodeSpec is a node
-- specification of the form "nodeType[:name attribute]".
parsePathSpec :: Text -> Parser GIRPath
parsePathSpec :: Text -> Parser GIRPath
parsePathSpec spec :: Text
spec = (Text
 -> WriterT
      Overrides (StateT ParserState (ExceptT Text IO)) GIRNodeSpec)
-> [Text] -> Parser GIRPath
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text
-> WriterT
     Overrides (StateT ParserState (ExceptT Text IO)) GIRNodeSpec
parseNodeSpec (Text -> Text -> [Text]
T.splitOn "/" Text
spec)

-- | A specification of a name, which is either a regex (prefixed with
-- "~") or a plain name.
parseGIRNameTag :: Text -> GIRNameTag
parseGIRNameTag :: Text -> GIRNameTag
parseGIRNameTag (Text -> Text -> Maybe Text
T.stripPrefix "~" -> Just regex :: Text
regex) = Text -> GIRNameTag
GIRRegex Text
regex
parseGIRNameTag t :: Text
t = Text -> GIRNameTag
GIRPlainName Text
t

-- | Parse a single node specification.
parseNodeSpec :: Text -> Parser GIRNodeSpec
parseNodeSpec :: Text
-> WriterT
     Overrides (StateT ParserState (ExceptT Text IO)) GIRNodeSpec
parseNodeSpec spec :: Text
spec = case Text -> Text -> [Text]
T.splitOn "@" Text
spec of
                       [n :: Text
n] -> GIRNodeSpec
-> WriterT
     Overrides (StateT ParserState (ExceptT Text IO)) GIRNodeSpec
forall (m :: * -> *) a. Monad m => a -> m a
return (GIRNameTag -> GIRNodeSpec
GIRNamed (Text -> GIRNameTag
parseGIRNameTag Text
n))
                       ["", t :: Text
t] -> GIRNodeSpec
-> WriterT
     Overrides (StateT ParserState (ExceptT Text IO)) GIRNodeSpec
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> GIRNodeSpec
GIRType Text
t)
                       [n :: Text
n, t :: Text
t] -> GIRNodeSpec
-> WriterT
     Overrides (StateT ParserState (ExceptT Text IO)) GIRNodeSpec
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> GIRNameTag -> GIRNodeSpec
GIRTypedName Text
t (Text -> GIRNameTag
parseGIRNameTag Text
n))
                       _ -> Text
-> WriterT
     Overrides (StateT ParserState (ExceptT Text IO)) GIRNodeSpec
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("Could not understand node spec \""
                                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
spec Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\".")

-- | Parse an XML name, with an optional prefix.
parseXMLName :: Text -> Parser XML.Name
parseXMLName :: Text -> Parser Name
parseXMLName a :: Text
a = case Text -> Text -> [Text]
T.splitOn ":" Text
a of
                   [n :: Text
n] -> Name -> Parser Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Name
xmlLocalName Text
n)
                   ["c", n :: Text
n] -> Name -> Parser Name
forall (m :: * -> *) a. Monad m => a -> m a
return (GIRXMLNamespace -> Text -> Name
xmlNSName GIRXMLNamespace
CGIRNS Text
n)
                   ["glib", n :: Text
n] -> Name -> Parser Name
forall (m :: * -> *) a. Monad m => a -> m a
return (GIRXMLNamespace -> Text -> Name
xmlNSName GIRXMLNamespace
GLibGIRNS Text
n)
                   ["core", n :: Text
n] -> Name -> Parser Name
forall (m :: * -> *) a. Monad m => a -> m a
return (GIRXMLNamespace -> Text -> Name
xmlNSName GIRXMLNamespace
CoreGIRNS Text
n)
                   _ -> Text -> Parser Name
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("Could not understand xml name \""
                                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\".")

-- | Known operating systems.
data OSType = Linux
            | OSX
            | Windows
              deriving (Int -> OSType -> ShowS
[OSType] -> ShowS
OSType -> String
(Int -> OSType -> ShowS)
-> (OSType -> String) -> ([OSType] -> ShowS) -> Show OSType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OSType] -> ShowS
$cshowList :: [OSType] -> ShowS
show :: OSType -> String
$cshow :: OSType -> String
showsPrec :: Int -> OSType -> ShowS
$cshowsPrec :: Int -> OSType -> ShowS
Show)

-- | Check whether we are running under the given OS.
checkOS :: String -> Parser Bool
checkOS :: String -> Parser Bool
checkOS os :: String
os = Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (String
SI.os String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
os)

-- | Parse a textual representation of a version into a `Data.Version.Version`.
parseVersion :: Text -> Parser V.Version
parseVersion :: Text -> Parser Version
parseVersion v :: Text
v = ([(Version, String)] -> Parser Version
chooseFullParse ([(Version, String)] -> Parser Version)
-> (Text -> [(Version, String)]) -> Text -> Parser Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadP Version -> ReadS Version
forall a. ReadP a -> ReadS a
readP_to_S ReadP Version
V.parseVersion ReadS Version -> (Text -> String) -> Text -> [(Version, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) Text
v
    where chooseFullParse :: [(V.Version, String)] -> Parser V.Version
          chooseFullParse :: [(Version, String)] -> Parser Version
chooseFullParse [] = Text -> Parser Version
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("Could not parse version \""
                                           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\".")
          chooseFullParse [(parsed :: Version
parsed, "")] = Version -> Parser Version
forall (m :: * -> *) a. Monad m => a -> m a
return Version
parsed
          chooseFullParse (_ : rest :: [(Version, String)]
rest) = [(Version, String)] -> Parser Version
chooseFullParse [(Version, String)]
rest

-- | Check that the given pkg-config package has a version compatible
-- with the given constraint.
checkPkgConfigVersion :: Text -> Text -> Text -> Parser Bool
checkPkgConfigVersion :: Text -> Text -> Text -> Parser Bool
checkPkgConfigVersion pkg :: Text
pkg op :: Text
op tVersion :: Text
tVersion = do
  Version
version <- Text -> Parser Version
parseVersion Text
tVersion
  Version
pcVersion <- IO (Maybe (Text, Text))
-> WriterT
     Overrides
     (StateT ParserState (ExceptT Text IO))
     (Maybe (Text, Text))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> IO (Maybe (Text, Text))
tryPkgConfig Text
pkg) WriterT
  Overrides
  (StateT ParserState (ExceptT Text IO))
  (Maybe (Text, Text))
-> (Maybe (Text, Text) -> Parser Version) -> Parser Version
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
               Nothing ->
                   Text -> Parser Version
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("Could not determine pkg-config version for \""
                               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pkg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\".")
               Just (_, tv :: Text
tv) -> Text -> Parser Version
parseVersion Text
tv
  case Text
op of
    "==" -> Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Version
pcVersion Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
version)
    "/=" -> Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Version
pcVersion Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/= Version
version)
    ">=" -> Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Version
pcVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
version)
    ">"  -> Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Version
pcVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>  Version
version)
    "<=" -> Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Version
pcVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
<= Version
version)
    "<"  -> Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Version
pcVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
<  Version
version)
    _    -> Text -> Parser Bool
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("Unrecognized comparison operator \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
op Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\".")

-- | Parse a 'if' directive.
parseIf :: Text -> Parser ()
parseIf :: Text -> Parser ()
parseIf cond :: Text
cond = case Text -> [Text]
T.words Text
cond of
                 [] -> Text -> Parser ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("Empty 'if' condition.")
                 ["linux"] -> String -> Parser Bool
checkOS "linux" Parser Bool -> (Bool -> Parser ()) -> Parser ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Parser ()
setFlag
                 ["osx"] -> String -> Parser Bool
checkOS "darwin" Parser Bool -> (Bool -> Parser ()) -> Parser ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Parser ()
setFlag
                 ["windows"] -> String -> Parser Bool
checkOS "mingw32" Parser Bool -> (Bool -> Parser ()) -> Parser ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Parser ()
setFlag
                 ("pkg-config-version" : rest :: [Text]
rest) ->
                     case [Text]
rest of
                       [pkg :: Text
pkg, op :: Text
op, version :: Text
version] ->
                           Text -> Text -> Text -> Parser Bool
checkPkgConfigVersion Text
pkg Text
op Text
version Parser Bool -> (Bool -> Parser ()) -> Parser ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Parser ()
setFlag
                       _ -> Text -> Parser ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("Syntax for `pkg-config-version' is "
                                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\"pkg op version\", got \""
                                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Show a => a -> Text
tshow [Text]
rest Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\".")
                 _ -> Text -> Parser ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("Unknown condition \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cond Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\".")
    where setFlag :: Bool -> Parser ()
          setFlag :: Bool -> Parser ()
setFlag flag :: Bool
flag = (ParserState -> ParserState) -> Parser ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\s :: ParserState
s -> ParserState
s {flags :: [Bool]
flags = Bool
flag Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: ParserState -> [Bool]
flags ParserState
s})

-- | Parse an 'endif' directive.
parseEndif :: Text -> Parser ()
parseEndif :: Text -> Parser ()
parseEndif rest :: Text
rest = case Text -> [Text]
T.words Text
rest of
                    [] -> Parser ()
unsetFlag
                    _ -> Text -> Parser ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("Unexpected argument to 'endif': \""
                                     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rest Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\".")
    where unsetFlag :: Parser ()
          unsetFlag :: Parser ()
unsetFlag = do
            ParserState
s <- WriterT
  Overrides (StateT ParserState (ExceptT Text IO)) ParserState
forall s (m :: * -> *). MonadState s m => m s
get
            case ParserState -> [Bool]
flags ParserState
s of
              _:rest :: [Bool]
rest -> ParserState -> Parser ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ParserState
s {flags :: [Bool]
flags = [Bool]
rest})
              [] -> Text -> Parser ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("'endif' with no matching 'if'.")

-- | Parse the given overrides file, and merge into the given context.
parseInclude :: Text -> Parser ()
parseInclude :: Text -> Parser ()
parseInclude fname :: Text
fname = do
  Text
includeText <- IO Text
-> WriterT Overrides (StateT ParserState (ExceptT Text IO)) Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text
 -> WriterT Overrides (StateT ParserState (ExceptT Text IO)) Text)
-> IO Text
-> WriterT Overrides (StateT ParserState (ExceptT Text IO)) Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
utf8ReadFile (Text -> String
T.unpack Text
fname)
  IO (Either Text Overrides)
-> WriterT
     Overrides
     (StateT ParserState (ExceptT Text IO))
     (Either Text Overrides)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> IO (Either Text Overrides)
parseOverrides Text
includeText) WriterT
  Overrides
  (StateT ParserState (ExceptT Text IO))
  (Either Text Overrides)
-> (Either Text Overrides -> Parser ()) -> Parser ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left err :: Text
err -> Text -> Parser ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ("Error when parsing included '"
                            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "': " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err)
    Right ovs :: Overrides
ovs -> Overrides -> Parser ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Overrides
ovs

-- | Filter a set of named objects based on a lookup list of names to
-- ignore.
filterMethods :: [Method] -> S.Set Text -> [Method]
filterMethods :: [Method] -> Set Text -> [Method]
filterMethods set :: [Method]
set ignores :: Set Text
ignores =
    (Method -> Bool) -> [Method] -> [Method]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set Text
ignores) (Text -> Bool) -> (Method -> Text) -> Method -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
name (Name -> Text) -> (Method -> Name) -> Method -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Name
methodName) [Method]
set

-- | Given the previous allocation info, and a new allocation info,
-- replace those entries in the old allocation info which are
-- specified in the new info.
filterAllocInfo :: AllocationInfo -> AllocationInfo -> AllocationInfo
filterAllocInfo :: AllocationInfo -> AllocationInfo -> AllocationInfo
filterAllocInfo old :: AllocationInfo
old new :: AllocationInfo
new =
    AllocationInfo :: AllocationOp -> AllocationOp -> AllocationOp -> AllocationInfo
AllocationInfo { allocCalloc :: AllocationOp
allocCalloc = AllocationOp -> AllocationOp -> AllocationOp
replace (AllocationInfo -> AllocationOp
allocCalloc AllocationInfo
old) (AllocationInfo -> AllocationOp
allocCalloc AllocationInfo
new)
                   , allocCopy :: AllocationOp
allocCopy = AllocationOp -> AllocationOp -> AllocationOp
replace (AllocationInfo -> AllocationOp
allocCopy AllocationInfo
old) (AllocationInfo -> AllocationOp
allocCopy AllocationInfo
new)
                   , allocFree :: AllocationOp
allocFree = AllocationOp -> AllocationOp -> AllocationOp
replace (AllocationInfo -> AllocationOp
allocFree AllocationInfo
old) (AllocationInfo -> AllocationOp
allocFree AllocationInfo
new) }
    where replace :: AllocationOp -> AllocationOp -> AllocationOp
          replace :: AllocationOp -> AllocationOp -> AllocationOp
replace o :: AllocationOp
o AllocationOpUnknown = AllocationOp
o
          replace _ o :: AllocationOp
o = AllocationOp
o

-- | Filter one API according to the given config.
filterOneAPI :: Overrides -> (Name, API, Maybe (S.Set Text)) -> (Name, API)
filterOneAPI :: Overrides -> (Name, API, Maybe (Set Text)) -> (Name, API)
filterOneAPI ovs :: Overrides
ovs (n :: Name
n, APIStruct s :: Struct
s, maybeIgnores :: Maybe (Set Text)
maybeIgnores) =
    (Name
n, Struct -> API
APIStruct Struct
s { structMethods :: [Method]
structMethods = [Method] -> (Set Text -> [Method]) -> Maybe (Set Text) -> [Method]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Struct -> [Method]
structMethods Struct
s)
                                      ([Method] -> Set Text -> [Method]
filterMethods (Struct -> [Method]
structMethods Struct
s))
                                      Maybe (Set Text)
maybeIgnores
                    , structFields :: [Field]
structFields = if Name
n Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Overrides -> Set Name
sealedStructs Overrides
ovs
                                    then []
                                    else Struct -> [Field]
structFields Struct
s
                    , structAllocationInfo :: AllocationInfo
structAllocationInfo =
                        let ai :: AllocationInfo
ai = Struct -> AllocationInfo
structAllocationInfo Struct
s
                        in case Name -> Map Name AllocationInfo -> Maybe AllocationInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n (Overrides -> Map Name AllocationInfo
allocInfo Overrides
ovs) of
                             Just info :: AllocationInfo
info -> AllocationInfo -> AllocationInfo -> AllocationInfo
filterAllocInfo AllocationInfo
ai AllocationInfo
info
                             Nothing -> AllocationInfo
ai
                    })
filterOneAPI ovs :: Overrides
ovs (n :: Name
n, APIUnion u :: Union
u, maybeIgnores :: Maybe (Set Text)
maybeIgnores) =
    (Name
n, Union -> API
APIUnion Union
u {unionMethods :: [Method]
unionMethods = [Method] -> (Set Text -> [Method]) -> Maybe (Set Text) -> [Method]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Union -> [Method]
unionMethods Union
u)
                                   ([Method] -> Set Text -> [Method]
filterMethods (Union -> [Method]
unionMethods Union
u))
                                   Maybe (Set Text)
maybeIgnores
                   , unionAllocationInfo :: AllocationInfo
unionAllocationInfo =
                        let ai :: AllocationInfo
ai = Union -> AllocationInfo
unionAllocationInfo Union
u
                        in case Name -> Map Name AllocationInfo -> Maybe AllocationInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n (Overrides -> Map Name AllocationInfo
allocInfo Overrides
ovs) of
                             Just info :: AllocationInfo
info -> AllocationInfo -> AllocationInfo -> AllocationInfo
filterAllocInfo AllocationInfo
ai AllocationInfo
info
                             Nothing -> AllocationInfo
ai
                   })
-- The rest only apply if there are ignores.
filterOneAPI _ (n :: Name
n, api :: API
api, Nothing) = (Name
n, API
api)
filterOneAPI _ (n :: Name
n, APIObject o :: Object
o, Just ignores :: Set Text
ignores) =
    (Name
n, Object -> API
APIObject Object
o {objMethods :: [Method]
objMethods = [Method] -> Set Text -> [Method]
filterMethods (Object -> [Method]
objMethods Object
o) Set Text
ignores,
                     objSignals :: [Signal]
objSignals = (Signal -> Bool) -> [Signal] -> [Signal]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set Text
ignores) (Text -> Bool) -> (Signal -> Text) -> Signal -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal -> Text
sigName)
                                  (Object -> [Signal]
objSignals Object
o)
                    })
filterOneAPI ovs :: Overrides
ovs (n :: Name
n, APIInterface i :: Interface
i, Just ignores :: Set Text
ignores) =
    (Name
n, Interface -> API
APIInterface Interface
i {ifMethods :: [Method]
ifMethods = [Method] -> Set Text -> [Method]
filterMethods (Interface -> [Method]
ifMethods Interface
i) Set Text
ignores,
                        ifSignals :: [Signal]
ifSignals = (Signal -> Bool) -> [Signal] -> [Signal]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set Text
ignores) (Text -> Bool) -> (Signal -> Text) -> Signal -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal -> Text
sigName)
                                    (Interface -> [Signal]
ifSignals Interface
i),
                        ifAllocationInfo :: AllocationInfo
ifAllocationInfo =
                           let ai :: AllocationInfo
ai = Interface -> AllocationInfo
ifAllocationInfo Interface
i
                           in case Name -> Map Name AllocationInfo -> Maybe AllocationInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n (Overrides -> Map Name AllocationInfo
allocInfo Overrides
ovs) of
                                Just info :: AllocationInfo
info -> AllocationInfo -> AllocationInfo -> AllocationInfo
filterAllocInfo AllocationInfo
ai AllocationInfo
info
                                Nothing -> AllocationInfo
ai

                       })
filterOneAPI _ (n :: Name
n, api :: API
api, _) = (Name
n, API
api)

-- | Given a list of APIs modify them according to the given config.
filterAPIs :: Overrides -> [(Name, API)] -> [(Name, API)]
filterAPIs :: Overrides -> [(Name, API)] -> [(Name, API)]
filterAPIs ovs :: Overrides
ovs apis :: [(Name, API)]
apis = ((Name, API) -> (Name, API)) -> [(Name, API)] -> [(Name, API)]
forall a b. (a -> b) -> [a] -> [b]
map (Overrides -> (Name, API, Maybe (Set Text)) -> (Name, API)
filterOneAPI Overrides
ovs ((Name, API, Maybe (Set Text)) -> (Name, API))
-> ((Name, API) -> (Name, API, Maybe (Set Text)))
-> (Name, API)
-> (Name, API)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, API) -> (Name, API, Maybe (Set Text))
forall b. (Name, b) -> (Name, b, Maybe (Set Text))
fetchIgnores) [(Name, API)]
filtered
    where filtered :: [(Name, API)]
filtered = ((Name, API) -> Bool) -> [(Name, API)] -> [(Name, API)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Overrides -> Set Name
ignoredAPIs Overrides
ovs) (Name -> Bool) -> ((Name, API) -> Name) -> (Name, API) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, API) -> Name
forall a b. (a, b) -> a
fst) [(Name, API)]
apis
          fetchIgnores :: (Name, b) -> (Name, b, Maybe (Set Text))
fetchIgnores (n :: Name
n, api :: b
api) = (Name
n, b
api, Name -> Map Name (Set Text) -> Maybe (Set Text)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n (Overrides -> Map Name (Set Text)
ignoredElems Overrides
ovs))

-- | Load a given API, applying filtering. Load also any necessary
-- dependencies.
filterAPIsAndDeps :: Overrides -> GIRInfo -> [GIRInfo]
                  -> (M.Map Name API, M.Map Name API)
filterAPIsAndDeps :: Overrides -> GIRInfo -> [GIRInfo] -> (Map Name API, Map Name API)
filterAPIsAndDeps ovs :: Overrides
ovs doc :: GIRInfo
doc deps :: [GIRInfo]
deps =
  let toMap :: GIRInfo -> Map Name API
toMap = [(Name, API)] -> Map Name API
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, API)] -> Map Name API)
-> (GIRInfo -> [(Name, API)]) -> GIRInfo -> Map Name API
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Overrides -> [(Name, API)] -> [(Name, API)]
filterAPIs Overrides
ovs ([(Name, API)] -> [(Name, API)])
-> (GIRInfo -> [(Name, API)]) -> GIRInfo -> [(Name, API)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GIRInfo -> [(Name, API)]
girAPIs
  in (GIRInfo -> Map Name API
toMap GIRInfo
doc, [Map Name API] -> Map Name API
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions ((GIRInfo -> Map Name API) -> [GIRInfo] -> [Map Name API]
forall a b. (a -> b) -> [a] -> [b]
map GIRInfo -> Map Name API
toMap [GIRInfo]
deps))