    {-# LANGUAGE CPP #-}
    {-# LANGUAGE ConstraintKinds #-}
    {-# LANGUAGE DeriveDataTypeable #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    module Language.C.Inline.HaskellIdentifier
      ( HaskellIdentifier
      , unHaskellIdentifier
      , haskellIdentifierFromString
      , haskellCParserContext
      , parseHaskellIdentifier
      , mangleHaskellIdentifier

        -- * for testing
      , haskellReservedWords
      ) where

    import           Control.Applicative ((<|>))
    import           Control.Monad (when, msum, void)
    import           Data.Char (ord)
    import qualified Data.HashSet as HashSet
    import           Data.Hashable (Hashable)
    import           Data.List (intercalate, partition, intersperse)
    import           Data.Monoid ((<>))
    import           Data.String (IsString(..))
    import           Data.Typeable (Typeable)
    import           Numeric (showHex)
    import           Text.Parser.Char (upper, lower, digit, char)
    import           Text.Parser.Combinators (many, eof, try, unexpected, (<?>))
    import           Text.Parser.Token (IdentifierStyle(..), highlight, TokenParsing)
    import qualified Text.Parser.Token.Highlight as Highlight
    import qualified Prettyprinter as PP

    import qualified Language.C.Types.Parse as C

    #if __GLASGOW_HASKELL__ < 710
    import           Control.Applicative ((<*), (<$>), (<*>))
    #endif

    -- | A possibly qualified Haskell identifier.
    newtype HaskellIdentifier = HaskellIdentifier {HaskellIdentifier -> String
    unHaskellIdentifier :: String}
      deriving (Typeable, HaskellIdentifier -> HaskellIdentifier -> Bool
    (HaskellIdentifier -> HaskellIdentifier -> Bool)
    -> (HaskellIdentifier -> HaskellIdentifier -> Bool)
    -> Eq HaskellIdentifier
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: HaskellIdentifier -> HaskellIdentifier -> Bool
    == :: HaskellIdentifier -> HaskellIdentifier -> Bool
    $c/= :: HaskellIdentifier -> HaskellIdentifier -> Bool
    /= :: HaskellIdentifier -> HaskellIdentifier -> Bool
    Eq, Eq HaskellIdentifier
    Eq HaskellIdentifier =>
    (HaskellIdentifier -> HaskellIdentifier -> Ordering)
    -> (HaskellIdentifier -> HaskellIdentifier -> Bool)
    -> (HaskellIdentifier -> HaskellIdentifier -> Bool)
    -> (HaskellIdentifier -> HaskellIdentifier -> Bool)
    -> (HaskellIdentifier -> HaskellIdentifier -> Bool)
    -> (HaskellIdentifier -> HaskellIdentifier -> HaskellIdentifier)
    -> (HaskellIdentifier -> HaskellIdentifier -> HaskellIdentifier)
    -> Ord HaskellIdentifier
    HaskellIdentifier -> HaskellIdentifier -> Bool
    HaskellIdentifier -> HaskellIdentifier -> Ordering
    HaskellIdentifier -> HaskellIdentifier -> HaskellIdentifier
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: HaskellIdentifier -> HaskellIdentifier -> Ordering
    compare :: HaskellIdentifier -> HaskellIdentifier -> Ordering
    $c< :: HaskellIdentifier -> HaskellIdentifier -> Bool
    < :: HaskellIdentifier -> HaskellIdentifier -> Bool
    $c<= :: HaskellIdentifier -> HaskellIdentifier -> Bool
    <= :: HaskellIdentifier -> HaskellIdentifier -> Bool
    $c> :: HaskellIdentifier -> HaskellIdentifier -> Bool
    > :: HaskellIdentifier -> HaskellIdentifier -> Bool
    $c>= :: HaskellIdentifier -> HaskellIdentifier -> Bool
    >= :: HaskellIdentifier -> HaskellIdentifier -> Bool
    $cmax :: HaskellIdentifier -> HaskellIdentifier -> HaskellIdentifier
    max :: HaskellIdentifier -> HaskellIdentifier -> HaskellIdentifier
    $cmin :: HaskellIdentifier -> HaskellIdentifier -> HaskellIdentifier
    min :: HaskellIdentifier -> HaskellIdentifier -> HaskellIdentifier
    Ord, Int -> HaskellIdentifier -> String -> String
    [HaskellIdentifier] -> String -> String
    HaskellIdentifier -> String
    (Int -> HaskellIdentifier -> String -> String)
    -> (HaskellIdentifier -> String)
    -> ([HaskellIdentifier] -> String -> String)
    -> Show HaskellIdentifier
    forall a.
    (Int -> a -> String -> String)
    -> (a -> String) -> ([a] -> String -> String) -> Show a
    $cshowsPrec :: Int -> HaskellIdentifier -> String -> String
    showsPrec :: Int -> HaskellIdentifier -> String -> String
    $cshow :: HaskellIdentifier -> String
    show :: HaskellIdentifier -> String
    $cshowList :: [HaskellIdentifier] -> String -> String
    showList :: [HaskellIdentifier] -> String -> String
    Show, Eq HaskellIdentifier
    Eq HaskellIdentifier =>
    (Int -> HaskellIdentifier -> Int)
    -> (HaskellIdentifier -> Int) -> Hashable HaskellIdentifier
    Int -> HaskellIdentifier -> Int
    HaskellIdentifier -> Int
    forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
    $chashWithSalt :: Int -> HaskellIdentifier -> Int
    hashWithSalt :: Int -> HaskellIdentifier -> Int
    $chash :: HaskellIdentifier -> Int
    hash :: HaskellIdentifier -> Int
    Hashable)

    instance IsString HaskellIdentifier where
      fromString :: String -> HaskellIdentifier
    fromString String
    s =
        case Bool -> String -> Either String HaskellIdentifier
    haskellIdentifierFromString Bool
    True String
    s of
          Left String
    err -> String -> HaskellIdentifier
    forall a. HasCallStack => String -> a
    error (String -> HaskellIdentifier) -> String -> HaskellIdentifier
    forall a b. (a -> b) -> a -> b
    $ String
    "HaskellIdentifier fromString: invalid string " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    s String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ":\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    err
          Right HaskellIdentifier
    x -> HaskellIdentifier
    x

    instance PP.Pretty HaskellIdentifier where
      pretty :: forall ann. HaskellIdentifier -> Doc ann
    pretty = String -> Doc ann
    forall a. IsString a => String -> a
    fromString (String -> Doc ann)
    -> (HaskellIdentifier -> String) -> HaskellIdentifier -> Doc ann
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . HaskellIdentifier -> String
    unHaskellIdentifier

    haskellIdentifierFromString :: Bool -> String -> Either String HaskellIdentifier
    haskellIdentifierFromString :: Bool -> String -> Either String HaskellIdentifier
    haskellIdentifierFromString Bool
    useCpp String
    s =
      case CParserContext HaskellIdentifier
    -> String
    -> String
    -> ReaderT
         (CParserContext HaskellIdentifier)
         (Parsec String ())
         HaskellIdentifier
    -> Either ParseError HaskellIdentifier
    forall s i a.
    Stream s Identity Char =>
    CParserContext i
    -> String
    -> s
    -> ReaderT (CParserContext i) (Parsec s ()) a
    -> Either ParseError a
    C.runCParser CParserContext HaskellIdentifier
    cpc String
    "haskellIdentifierFromString" String
    s (ReaderT
      (CParserContext HaskellIdentifier)
      (Parsec String ())
      HaskellIdentifier
    forall i (m :: * -> *). CParser i m => m HaskellIdentifier
    parseHaskellIdentifier ReaderT
      (CParserContext HaskellIdentifier)
      (Parsec String ())
      HaskellIdentifier
    -> ReaderT (CParserContext HaskellIdentifier) (Parsec String ()) ()
    -> ReaderT
         (CParserContext HaskellIdentifier)
         (Parsec String ())
         HaskellIdentifier
    forall a b.
    ReaderT (CParserContext HaskellIdentifier) (Parsec String ()) a
    -> ReaderT (CParserContext HaskellIdentifier) (Parsec String ()) b
    -> ReaderT (CParserContext HaskellIdentifier) (Parsec String ()) a
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
    <* ReaderT (CParserContext HaskellIdentifier) (Parsec String ()) ()
    forall (m :: * -> *). Parsing m => m ()
    eof) of
        Left ParseError
    err -> String -> Either String HaskellIdentifier
    forall a b. a -> Either a b
    Left (String -> Either String HaskellIdentifier)
    -> String -> Either String HaskellIdentifier
    forall a b. (a -> b) -> a -> b
    $ ParseError -> String
    forall a. Show a => a -> String
    show ParseError
    err
        Right HaskellIdentifier
    x -> HaskellIdentifier -> Either String HaskellIdentifier
    forall a b. b -> Either a b
    Right HaskellIdentifier
    x
      where
        cpc :: CParserContext HaskellIdentifier
    cpc = Bool -> TypeNames -> CParserContext HaskellIdentifier
    haskellCParserContext Bool
    useCpp TypeNames
    forall a. HashSet a
    HashSet.empty

    haskellCParserContext :: Bool -> C.TypeNames -> C.CParserContext HaskellIdentifier
    haskellCParserContext :: Bool -> TypeNames -> CParserContext HaskellIdentifier
    haskellCParserContext Bool
    useCpp TypeNames
    typeNames = C.CParserContext
      { cpcTypeNames :: TypeNames
    C.cpcTypeNames = TypeNames
    typeNames
      , cpcParseIdent :: forall (m :: * -> *).
    CParser HaskellIdentifier m =>
    m HaskellIdentifier
    C.cpcParseIdent = m HaskellIdentifier
    forall i (m :: * -> *). CParser i m => m HaskellIdentifier
    forall (m :: * -> *).
    CParser HaskellIdentifier m =>
    m HaskellIdentifier
    parseHaskellIdentifier
      , cpcIdentName :: String
    C.cpcIdentName = String
    "Haskell identifier"
      , cpcIdentToString :: HaskellIdentifier -> String
    C.cpcIdentToString = HaskellIdentifier -> String
    unHaskellIdentifier
      , cpcEnableCpp :: Bool
    C.cpcEnableCpp = Bool
    useCpp
      }

    -- | See
    -- <https://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-160002.2>.
    haskellIdentStyle :: C.CParser i m => IdentifierStyle m
    haskellIdentStyle :: forall i (m :: * -> *). CParser i m => IdentifierStyle m
    haskellIdentStyle = IdentifierStyle
      { _styleName :: String
    _styleName = String
    "Haskell identifier"
      , _styleStart :: m Char
    _styleStart = m Char
    small
      , _styleLetter :: m Char
    _styleLetter = m Char
    small m Char -> m Char -> m Char
    forall a. m a -> m a -> m a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> m Char
    large m Char -> m Char -> m Char
    forall a. m a -> m a -> m a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> m Char
    forall (m :: * -> *). CharParsing m => m Char
    digit m Char -> m Char -> m Char
    forall a. m a -> m a -> m a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> Char -> m Char
    forall (m :: * -> *). CharParsing m => Char -> m Char
    char Char
    '\''
      , _styleReserved :: HashSet String
    _styleReserved = HashSet String
    haskellReservedWords
      , _styleHighlight :: Highlight
    _styleHighlight = Highlight
    Highlight.Identifier
      , _styleReservedHighlight :: Highlight
    _styleReservedHighlight = Highlight
    Highlight.ReservedIdentifier
      }
      where
        small :: m Char
    small = m Char
    forall (m :: * -> *). CharParsing m => m Char
    lower m Char -> m Char -> m Char
    forall a. m a -> m a -> m a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> Char -> m Char
    forall (m :: * -> *). CharParsing m => Char -> m Char
    char Char
    '_'
        large :: m Char
    large = m Char
    forall (m :: * -> *). CharParsing m => m Char
    upper

    -- We disallow both Haskell reserved words and C reserved words.
    haskellReservedWords :: HashSet.HashSet String
    haskellReservedWords :: HashSet String
    haskellReservedWords = HashSet String
    C.cReservedWords HashSet String -> HashSet String -> HashSet String
    forall a. Semigroup a => a -> a -> a
    <> [String] -> HashSet String
    forall a. (Eq a, Hashable a) => [a] -> HashSet a
    HashSet.fromList
      [ String
    "case", String
    "class", String
    "data", String
    "default", String
    "deriving", String
    "do", String
    "else"
      , String
    "foreign", String
    "if", String
    "import", String
    "in", String
    "infix", String
    "infixl"
      , String
    "infixr", String
    "instance", String
    "let", String
    "module", String
    "newtype", String
    "of"
      , String
    "then", String
    "type", String
    "where"
      ]

    -- | See
    -- <https://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-160002.2>.
    parseHaskellIdentifier :: forall i m. C.CParser i m => m HaskellIdentifier
    parseHaskellIdentifier :: forall i (m :: * -> *). CParser i m => m HaskellIdentifier
    parseHaskellIdentifier = do
      segments <- m [String]
    go
      return $ HaskellIdentifier $ intercalate "." segments
      where
        small :: m Char
    small = m Char
    forall (m :: * -> *). CharParsing m => m Char
    lower m Char -> m Char -> m Char
    forall a. m a -> m a -> m a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> Char -> m Char
    forall (m :: * -> *). CharParsing m => Char -> m Char
    char Char
    '_'
        large :: m Char
    large = m Char
    forall (m :: * -> *). CharParsing m => m Char
    upper

        conid :: m String
        conid :: m String
    conid = m String -> m String
    forall a. m a -> m a
    forall (m :: * -> *) a. Parsing m => m a -> m a
    try (m String -> m String) -> m String -> m String
    forall a b. (a -> b) -> a -> b
    $ Highlight -> m String -> m String
    forall a. Highlight -> m a -> m a
    forall (m :: * -> *) a. TokenParsing m => Highlight -> m a -> m a
    highlight Highlight
    Highlight.Identifier (m String -> m String) -> m String -> m String
    forall a b. (a -> b) -> a -> b
    $
          ((:) (Char -> String -> String) -> m Char -> m (String -> String)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> m Char
    large m (String -> String) -> m String -> m String
    forall a b. m (a -> b) -> m a -> m b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> m Char -> m String
    forall a. m a -> m [a]
    forall (f :: * -> *) a. Alternative f => f a -> f [a]
    many (m Char
    small m Char -> m Char -> m Char
    forall a. m a -> m a -> m a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> m Char
    large m Char -> m Char -> m Char
    forall a. m a -> m a -> m a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> m Char
    forall (m :: * -> *). CharParsing m => m Char
    digit m Char -> m Char -> m Char
    forall a. m a -> m a -> m a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> Char -> m Char
    forall (m :: * -> *). CharParsing m => Char -> m Char
    char Char
    '\'')) m String -> String -> m String
    forall a. m a -> String -> m a
    forall (m :: * -> *) a. Parsing m => m a -> String -> m a
    <?> String
    "Haskell constructor"

        varid :: m String
        varid :: m String
    varid = IdentifierStyle m -> m String
    forall (m :: * -> *) s.
    (TokenParsing m, Monad m, IsString s) =>
    IdentifierStyle m -> m s
    identNoLex IdentifierStyle m
    forall i (m :: * -> *). CParser i m => IdentifierStyle m
    haskellIdentStyle

        go :: m [String]
    go = [m [String]] -> m [String]
    forall (t :: * -> *) (m :: * -> *) a.
    (Foldable t, MonadPlus m) =>
    t (m a) -> m a
    msum
          [ do con <- m String
    conid
               msum
                 [ do void $ char '.'
                      (con :) <$> go
                 , return [con]
                 ]
          , do var <- m String
    varid
               return [var]
          ]

    -- | Mangles an 'HaskellIdentifier' to produce a valid 'C.CIdentifier'
    -- which still sort of resembles the 'HaskellIdentifier'.
    mangleHaskellIdentifier :: Bool -> HaskellIdentifier -> C.CIdentifier
    mangleHaskellIdentifier :: Bool -> HaskellIdentifier -> CIdentifier
    mangleHaskellIdentifier Bool
    useCpp (HaskellIdentifier String
    hs) =
      -- The leading underscore if we have no valid chars is because then
      -- we'd have an identifier starting with numbers.
      let cs :: String
    cs = (if String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    valid then String
    "_" else String
    "") String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
               String
    valid String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
               (if String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    mangled Bool -> Bool -> Bool
    || String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    valid then String
    "" else String
    "_") String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
               String
    mangled
      in case Bool -> String -> Either String CIdentifier
    C.cIdentifierFromString Bool
    useCpp String
    cs of
        Left String
    err -> String -> CIdentifier
    forall a. HasCallStack => String -> a
    error (String -> CIdentifier) -> String -> CIdentifier
    forall a b. (a -> b) -> a -> b
    $ String
    "mangleHaskellIdentifier: produced bad C identifier\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    err
        Right CIdentifier
    x -> CIdentifier
    x
      where
        (String
    valid, String
    invalid) = (Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    partition (Char -> String -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` String
    C.cIdentLetter) String
    hs

        mangled :: String
    mangled = [String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([String] -> String) -> [String] -> String
    forall a b. (a -> b) -> a -> b
    $ String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    intersperse String
    "_" ([String] -> [String]) -> [String] -> [String]
    forall a b. (a -> b) -> a -> b
    $ (Int -> String) -> [Int] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> String -> String
    forall a. Integral a => a -> String -> String
    `showHex` String
    "") ([Int] -> [String]) -> [Int] -> [String]
    forall a b. (a -> b) -> a -> b
    $ (Char -> Int) -> String -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> Int
    ord String
    invalid

    -- Utils
    ------------------------------------------------------------------------

    identNoLex :: (TokenParsing m, Monad m, IsString s) => IdentifierStyle m -> m s
    identNoLex :: forall (m :: * -> *) s.
    (TokenParsing m, Monad m, IsString s) =>
    IdentifierStyle m -> m s
    identNoLex IdentifierStyle m
    s = (String -> s) -> m String -> m s
    forall a b. (a -> b) -> m a -> m b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap String -> s
    forall a. IsString a => String -> a
    fromString (m String -> m s) -> m String -> m s
    forall a b. (a -> b) -> a -> b
    $ m String -> m String
    forall a. m a -> m a
    forall (m :: * -> *) a. Parsing m => m a -> m a
    try (m String -> m String) -> m String -> m String
    forall a b. (a -> b) -> a -> b
    $ do
      name <- Highlight -> m String -> m String
    forall a. Highlight -> m a -> m a
    forall (m :: * -> *) a. TokenParsing m => Highlight -> m a -> m a
    highlight (IdentifierStyle m -> Highlight
    forall (m :: * -> *). IdentifierStyle m -> Highlight
    _styleHighlight IdentifierStyle m
    s)
              ((:) (Char -> String -> String) -> m Char -> m (String -> String)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IdentifierStyle m -> m Char
    forall (m :: * -> *). IdentifierStyle m -> m Char
    _styleStart IdentifierStyle m
    s m (String -> String) -> m String -> m String
    forall a b. m (a -> b) -> m a -> m b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> m Char -> m String
    forall a. m a -> m [a]
    forall (f :: * -> *) a. Alternative f => f a -> f [a]
    many (IdentifierStyle m -> m Char
    forall (m :: * -> *). IdentifierStyle m -> m Char
    _styleLetter IdentifierStyle m
    s) m String -> String -> m String
    forall a. m a -> String -> m a
    forall (m :: * -> *) a. Parsing m => m a -> String -> m a
    <?> IdentifierStyle m -> String
    forall (m :: * -> *). IdentifierStyle m -> String
    _styleName IdentifierStyle m
    s)
      when (HashSet.member name (_styleReserved s)) $ unexpected $ "reserved " ++ _styleName s ++ " " ++ show name
      return name