{-# 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
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
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
Ord, Int -> HaskellIdentifier -> String -> String
[HaskellIdentifier] -> String -> String
HaskellIdentifier -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [HaskellIdentifier] -> String -> String
$cshowList :: [HaskellIdentifier] -> String -> String
show :: HaskellIdentifier -> String
$cshow :: HaskellIdentifier -> String
showsPrec :: Int -> HaskellIdentifier -> String -> String
$cshowsPrec :: Int -> HaskellIdentifier -> String -> String
Show, Eq 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
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 -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"HaskellIdentifier fromString: invalid string " forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
":\n" forall a. [a] -> [a] -> [a]
++ String
err
      Right HaskellIdentifier
x -> HaskellIdentifier
x

instance PP.Pretty HaskellIdentifier where
  pretty :: forall ann. HaskellIdentifier -> Doc ann
pretty = forall a. IsString a => String -> a
fromString 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 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 (forall i (m :: * -> *). CParser i m => m HaskellIdentifier
parseHaskellIdentifier forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). Parsing m => m ()
eof) of
    Left ParseError
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ParseError
err
    Right HaskellIdentifier
x -> forall a b. b -> Either a b
Right HaskellIdentifier
x
  where
    cpc :: CParserContext HaskellIdentifier
cpc = Bool -> TypeNames -> CParserContext HaskellIdentifier
haskellCParserContext Bool
useCpp 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 = forall i (m :: * -> *). CParser i 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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Char
large forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *). CharParsing m => m Char
digit forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> 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 = forall (m :: * -> *). CharParsing m => m Char
lower forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'_'
    large :: m Char
large = 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 forall a. Semigroup a => a -> a -> a
<> 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
  [String]
segments <- m [String]
go
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> HaskellIdentifier
HaskellIdentifier forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
"." [String]
segments
  where
    small :: m Char
small = forall (m :: * -> *). CharParsing m => m Char
lower forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'_'
    large :: m Char
large = forall (m :: * -> *). CharParsing m => m Char
upper

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

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

    go :: m [String]
go = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
      [ do String
con <- m String
conid
           forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
             [ do forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'.'
                  (String
con forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [String]
go
             , forall (m :: * -> *) a. Monad m => a -> m a
return [String
con]
             ]
      , do String
var <- m String
varid
           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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
valid then String
"_" else String
"") forall a. [a] -> [a] -> [a]
++
           String
valid forall a. [a] -> [a] -> [a]
++
           (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
mangled Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
valid then String
"" else 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 -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"mangleHaskellIdentifier: produced bad C identifier\n" forall a. [a] -> [a] -> [a]
++ String
err
    Right CIdentifier
x -> CIdentifier
x
  where
    (String
valid, String
invalid) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
C.cIdentLetter) String
hs

    mangled :: String
mangled = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse String
"_" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. (Integral a, Show a) => a -> String -> String
`showHex` String
"") forall a b. (a -> b) -> a -> b
$ 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Parsing m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ do
  String
name <- forall (m :: * -> *) a. TokenParsing m => Highlight -> m a -> m a
highlight (forall (m :: * -> *). IdentifierStyle m -> Highlight
_styleHighlight IdentifierStyle m
s)
          ((:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). IdentifierStyle m -> m Char
_styleStart IdentifierStyle m
s forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall (m :: * -> *). IdentifierStyle m -> m Char
_styleLetter IdentifierStyle m
s) forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> forall (m :: * -> *). IdentifierStyle m -> String
_styleName IdentifierStyle m
s)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
HashSet.member String
name (forall (m :: * -> *). IdentifierStyle m -> HashSet String
_styleReserved IdentifierStyle m
s)) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Parsing m => String -> m a
unexpected forall a b. (a -> b) -> a -> b
$ String
"reserved " forall a. [a] -> [a] -> [a]
++ forall (m :: * -> *). IdentifierStyle m -> String
_styleName IdentifierStyle m
s forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
name
  forall (m :: * -> *) a. Monad m => a -> m a
return String
name