{-# 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 Text.PrettyPrint.ANSI.Leijen 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
/= :: HaskellIdentifier -> HaskellIdentifier -> Bool
$c/= :: HaskellIdentifier -> HaskellIdentifier -> Bool
== :: HaskellIdentifier -> HaskellIdentifier -> Bool
$c== :: 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
min :: HaskellIdentifier -> HaskellIdentifier -> HaskellIdentifier
$cmin :: HaskellIdentifier -> HaskellIdentifier -> HaskellIdentifier
max :: HaskellIdentifier -> HaskellIdentifier -> HaskellIdentifier
$cmax :: HaskellIdentifier -> HaskellIdentifier -> HaskellIdentifier
>= :: HaskellIdentifier -> HaskellIdentifier -> Bool
$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
compare :: HaskellIdentifier -> HaskellIdentifier -> Ordering
$ccompare :: HaskellIdentifier -> HaskellIdentifier -> Ordering
$cp1Ord :: Eq HaskellIdentifier
Ord, Int -> HaskellIdentifier -> ShowS
[HaskellIdentifier] -> ShowS
HaskellIdentifier -> String
(Int -> HaskellIdentifier -> ShowS)
-> (HaskellIdentifier -> String)
-> ([HaskellIdentifier] -> ShowS)
-> Show HaskellIdentifier
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HaskellIdentifier] -> ShowS
$cshowList :: [HaskellIdentifier] -> ShowS
show :: HaskellIdentifier -> String
$cshow :: HaskellIdentifier -> String
showsPrec :: Int -> HaskellIdentifier -> ShowS
$cshowsPrec :: Int -> HaskellIdentifier -> ShowS
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
hash :: HaskellIdentifier -> Int
$chash :: HaskellIdentifier -> Int
hashWithSalt :: Int -> HaskellIdentifier -> Int
$chashWithSalt :: Int -> HaskellIdentifier -> Int
$cp1Hashable :: Eq HaskellIdentifier
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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err
      Right HaskellIdentifier
x -> HaskellIdentifier
x

instance PP.Pretty HaskellIdentifier where
  pretty :: HaskellIdentifier -> Doc
pretty = String -> Doc
PP.text (String -> Doc)
-> (HaskellIdentifier -> String) -> HaskellIdentifier -> Doc
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 (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 = CParserContext :: forall i.
String
-> TypeNames
-> (forall (m :: * -> *). CParser i m => m i)
-> (i -> String)
-> Bool
-> CParserContext i
C.CParserContext
  { cpcTypeNames :: TypeNames
C.cpcTypeNames = TypeNames
typeNames
  , cpcParseIdent :: forall (m :: * -> *).
CParser HaskellIdentifier m =>
m HaskellIdentifier
C.cpcParseIdent = 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 :: IdentifierStyle m
haskellIdentStyle = IdentifierStyle :: forall (m :: * -> *).
String
-> m Char
-> m Char
-> HashSet String
-> Highlight
-> Highlight
-> IdentifierStyle m
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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Char
large m Char -> m Char -> m Char
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 (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 (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 :: m HaskellIdentifier
parseHaskellIdentifier = do
  [String]
segments <- m [String]
go
  HaskellIdentifier -> m HaskellIdentifier
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskellIdentifier -> m HaskellIdentifier)
-> HaskellIdentifier -> m HaskellIdentifier
forall a b. (a -> b) -> a -> b
$ String -> HaskellIdentifier
HaskellIdentifier (String -> HaskellIdentifier) -> String -> HaskellIdentifier
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." [String]
segments
  where
    small :: m Char
small = m Char
forall (m :: * -> *). CharParsing m => m Char
lower m Char -> m Char -> m Char
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 (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 (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 -> ShowS) -> m Char -> m ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char
large m ShowS -> m String -> m String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Char -> m String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (m Char
small m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Char
large m Char -> m Char -> m Char
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 (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 (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 String
con <- m String
conid
           [m [String]] -> m [String]
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
             [ do m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Char -> m ()) -> m Char -> m ()
forall a b. (a -> b) -> a -> b
$ Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'.'
                  (String
con String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([String] -> [String]) -> m [String] -> m [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [String]
go
             , [String] -> m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
con]
             ]
      , do String
var <- m String
varid
           [String] -> m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
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 (t :: * -> *) a. Foldable t => t a -> Bool
null String
valid then String
"_" else String
"") String -> ShowS
forall a. [a] -> [a] -> [a]
++
           String
valid String -> ShowS
forall a. [a] -> [a] -> [a]
++
           (if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
mangled Bool -> Bool -> Bool
|| String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
valid then String
"" else String
"_") String -> ShowS
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 -> ShowS
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 (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 -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
`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 :: IdentifierStyle m -> m s
identNoLex IdentifierStyle m
s = (String -> s) -> m String -> m s
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 (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
  String
name <- Highlight -> m String -> m String
forall (m :: * -> *) a. TokenParsing m => Highlight -> m a -> m a
highlight (IdentifierStyle m -> Highlight
forall (m :: * -> *). IdentifierStyle m -> Highlight
_styleHighlight IdentifierStyle m
s)
          ((:) (Char -> ShowS) -> m Char -> m ShowS
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 ShowS -> m String -> m String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Char -> m String
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 (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> IdentifierStyle m -> String
forall (m :: * -> *). IdentifierStyle m -> String
_styleName IdentifierStyle m
s)
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> HashSet String -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
HashSet.member String
name (IdentifierStyle m -> HashSet String
forall (m :: * -> *). IdentifierStyle m -> HashSet String
_styleReserved IdentifierStyle m
s)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall (m :: * -> *) a. Parsing m => String -> m a
unexpected (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"reserved " String -> ShowS
forall a. [a] -> [a] -> [a]
++ IdentifierStyle m -> String
forall (m :: * -> *). IdentifierStyle m -> String
_styleName IdentifierStyle m
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
name
  String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
name