{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
module Text.Parser.Token.Style
(
CommentStyle(..)
, commentStart
, commentEnd
, commentLine
, commentNesting
, emptyCommentStyle
, javaCommentStyle
, scalaCommentStyle
, haskellCommentStyle
, buildSomeSpaceParser
, emptyIdents, haskellIdents, haskell98Idents
, emptyOps, haskellOps, haskell98Ops
) where
import Control.Applicative
import Control.Monad (void)
import qualified Data.HashSet as HashSet
import Data.HashSet (HashSet)
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
#endif
import Data.Data
import Text.Parser.Combinators
import Text.Parser.Char
import Text.Parser.Token
import Text.Parser.Token.Highlight
import Data.List (nub)
data =
{ :: String
, :: String
, :: String
, :: Bool
} deriving (CommentStyle -> CommentStyle -> Bool
(CommentStyle -> CommentStyle -> Bool)
-> (CommentStyle -> CommentStyle -> Bool) -> Eq CommentStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CommentStyle -> CommentStyle -> Bool
$c/= :: CommentStyle -> CommentStyle -> Bool
== :: CommentStyle -> CommentStyle -> Bool
$c== :: CommentStyle -> CommentStyle -> Bool
Eq,Eq CommentStyle
Eq CommentStyle
-> (CommentStyle -> CommentStyle -> Ordering)
-> (CommentStyle -> CommentStyle -> Bool)
-> (CommentStyle -> CommentStyle -> Bool)
-> (CommentStyle -> CommentStyle -> Bool)
-> (CommentStyle -> CommentStyle -> Bool)
-> (CommentStyle -> CommentStyle -> CommentStyle)
-> (CommentStyle -> CommentStyle -> CommentStyle)
-> Ord CommentStyle
CommentStyle -> CommentStyle -> Bool
CommentStyle -> CommentStyle -> Ordering
CommentStyle -> CommentStyle -> CommentStyle
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 :: CommentStyle -> CommentStyle -> CommentStyle
$cmin :: CommentStyle -> CommentStyle -> CommentStyle
max :: CommentStyle -> CommentStyle -> CommentStyle
$cmax :: CommentStyle -> CommentStyle -> CommentStyle
>= :: CommentStyle -> CommentStyle -> Bool
$c>= :: CommentStyle -> CommentStyle -> Bool
> :: CommentStyle -> CommentStyle -> Bool
$c> :: CommentStyle -> CommentStyle -> Bool
<= :: CommentStyle -> CommentStyle -> Bool
$c<= :: CommentStyle -> CommentStyle -> Bool
< :: CommentStyle -> CommentStyle -> Bool
$c< :: CommentStyle -> CommentStyle -> Bool
compare :: CommentStyle -> CommentStyle -> Ordering
$ccompare :: CommentStyle -> CommentStyle -> Ordering
$cp1Ord :: Eq CommentStyle
Ord,Int -> CommentStyle -> ShowS
[CommentStyle] -> ShowS
CommentStyle -> String
(Int -> CommentStyle -> ShowS)
-> (CommentStyle -> String)
-> ([CommentStyle] -> ShowS)
-> Show CommentStyle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CommentStyle] -> ShowS
$cshowList :: [CommentStyle] -> ShowS
show :: CommentStyle -> String
$cshow :: CommentStyle -> String
showsPrec :: Int -> CommentStyle -> ShowS
$cshowsPrec :: Int -> CommentStyle -> ShowS
Show,ReadPrec [CommentStyle]
ReadPrec CommentStyle
Int -> ReadS CommentStyle
ReadS [CommentStyle]
(Int -> ReadS CommentStyle)
-> ReadS [CommentStyle]
-> ReadPrec CommentStyle
-> ReadPrec [CommentStyle]
-> Read CommentStyle
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [CommentStyle]
$creadListPrec :: ReadPrec [CommentStyle]
readPrec :: ReadPrec CommentStyle
$creadPrec :: ReadPrec CommentStyle
readList :: ReadS [CommentStyle]
$creadList :: ReadS [CommentStyle]
readsPrec :: Int -> ReadS CommentStyle
$creadsPrec :: Int -> ReadS CommentStyle
Read,,Typeable)
commentStart :: Functor f => (String -> f String) -> CommentStyle -> f CommentStyle
String -> f String
f (CommentStyle String
s String
e String
l Bool
n) = (\String
s' -> String -> String -> String -> Bool -> CommentStyle
CommentStyle String
s' String
e String
l Bool
n) (String -> CommentStyle) -> f String -> f CommentStyle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> f String
f String
s
{-# INLINE commentStart #-}
commentEnd :: Functor f => (String -> f String) -> CommentStyle -> f CommentStyle
String -> f String
f (CommentStyle String
s String
e String
l Bool
n) = (\String
e' -> String -> String -> String -> Bool -> CommentStyle
CommentStyle String
s String
e' String
l Bool
n) (String -> CommentStyle) -> f String -> f CommentStyle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> f String
f String
e
{-# INLINE commentEnd #-}
commentLine :: Functor f => (String -> f String) -> CommentStyle -> f CommentStyle
String -> f String
f (CommentStyle String
s String
e String
l Bool
n) = (\String
l' -> String -> String -> String -> Bool -> CommentStyle
CommentStyle String
s String
e String
l' Bool
n) (String -> CommentStyle) -> f String -> f CommentStyle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> f String
f String
l
{-# INLINE commentLine #-}
commentNesting :: Functor f => (Bool -> f Bool) -> CommentStyle -> f CommentStyle
Bool -> f Bool
f (CommentStyle String
s String
e String
l Bool
n) = String -> String -> String -> Bool -> CommentStyle
CommentStyle String
s String
e String
l (Bool -> CommentStyle) -> f Bool -> f CommentStyle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> f Bool
f Bool
n
{-# INLINE commentNesting #-}
emptyCommentStyle :: CommentStyle
= String -> String -> String -> Bool -> CommentStyle
CommentStyle String
"" String
"" String
"" Bool
True
javaCommentStyle :: CommentStyle
= String -> String -> String -> Bool -> CommentStyle
CommentStyle String
"/*" String
"*/" String
"//" Bool
False
scalaCommentStyle :: CommentStyle
= String -> String -> String -> Bool -> CommentStyle
CommentStyle String
"/*" String
"*/" String
"//" Bool
True
haskellCommentStyle :: CommentStyle
= String -> String -> String -> Bool -> CommentStyle
CommentStyle String
"{-" String
"-}" String
"--" Bool
True
buildSomeSpaceParser :: forall m. CharParsing m => m () -> CommentStyle -> m ()
buildSomeSpaceParser :: m () -> CommentStyle -> m ()
buildSomeSpaceParser m ()
simpleSpace (CommentStyle String
startStyle String
endStyle String
lineStyle Bool
nestingStyle)
| Bool
noLine Bool -> Bool -> Bool
&& Bool
noMulti = m () -> m ()
forall (m :: * -> *) a. Parsing m => m a -> m ()
skipSome (m ()
simpleSpace m () -> String -> m ()
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"")
| Bool
noLine = m () -> m ()
forall (m :: * -> *) a. Parsing m => m a -> m ()
skipSome (m ()
simpleSpace m () -> m () -> m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m ()
multiLineComment m () -> String -> m ()
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"")
| Bool
noMulti = m () -> m ()
forall (m :: * -> *) a. Parsing m => m a -> m ()
skipSome (m ()
simpleSpace m () -> m () -> m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m ()
oneLineComment m () -> String -> m ()
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"")
| Bool
otherwise = m () -> m ()
forall (m :: * -> *) a. Parsing m => m a -> m ()
skipSome (m ()
simpleSpace m () -> m () -> m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m ()
oneLineComment m () -> m () -> m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m ()
multiLineComment m () -> String -> m ()
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"")
where
noLine :: Bool
noLine = String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
lineStyle
noMulti :: Bool
noMulti = String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
startStyle
oneLineComment, multiLineComment, inComment, inCommentMulti :: m ()
oneLineComment :: m ()
oneLineComment = m String -> m String
forall (m :: * -> *) a. Parsing m => m a -> m a
try (String -> m String
forall (m :: * -> *). CharParsing m => String -> m String
string String
lineStyle) m String -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m Char -> m ()
forall (m :: * -> *) a. Parsing m => m a -> m ()
skipMany ((Char -> Bool) -> m Char
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n'))
multiLineComment :: m ()
multiLineComment = m String -> m String
forall (m :: * -> *) a. Parsing m => m a -> m a
try (String -> m String
forall (m :: * -> *). CharParsing m => String -> m String
string String
startStyle) m String -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m ()
inComment
inComment :: m ()
inComment = if Bool
nestingStyle then m ()
inCommentMulti else m ()
inCommentSingle
inCommentMulti :: m ()
inCommentMulti
= m String -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m String -> m String
forall (m :: * -> *) a. Parsing m => m a -> m a
try (String -> m String
forall (m :: * -> *). CharParsing m => String -> m String
string String
endStyle))
m () -> m () -> m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m ()
multiLineComment m () -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m ()
inCommentMulti
m () -> m () -> m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Char -> m ()
forall (m :: * -> *) a. Parsing m => m a -> m ()
skipSome (String -> m Char
forall (m :: * -> *). CharParsing m => String -> m Char
noneOf String
startEnd) m () -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m ()
inCommentMulti
m () -> m () -> m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> m Char
forall (m :: * -> *). CharParsing m => String -> m Char
oneOf String
startEnd m Char -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m ()
inCommentMulti
m () -> String -> m ()
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"end of comment"
startEnd :: String
startEnd = ShowS
forall a. Eq a => [a] -> [a]
nub (String
endStyle String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
startStyle)
inCommentSingle :: m ()
inCommentSingle :: m ()
inCommentSingle
= m String -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m String -> m String
forall (m :: * -> *) a. Parsing m => m a -> m a
try (String -> m String
forall (m :: * -> *). CharParsing m => String -> m String
string String
endStyle))
m () -> m () -> m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Char -> m ()
forall (m :: * -> *) a. Parsing m => m a -> m ()
skipSome (String -> m Char
forall (m :: * -> *). CharParsing m => String -> m Char
noneOf String
startEnd) m () -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m ()
inCommentSingle
m () -> m () -> m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> m Char
forall (m :: * -> *). CharParsing m => String -> m Char
oneOf String
startEnd m Char -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m ()
inCommentSingle
m () -> String -> m ()
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"end of comment"
set :: [String] -> HashSet String
set :: [String] -> HashSet String
set = [String] -> HashSet String
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList
emptyOps :: TokenParsing m => IdentifierStyle m
emptyOps :: IdentifierStyle m
emptyOps = IdentifierStyle :: forall (m :: * -> *).
String
-> m Char
-> m Char
-> HashSet String
-> Highlight
-> Highlight
-> IdentifierStyle m
IdentifierStyle
{ _styleName :: String
_styleName = String
"operator"
, _styleStart :: m Char
_styleStart = IdentifierStyle m -> m Char
forall (m :: * -> *). IdentifierStyle m -> m Char
_styleLetter IdentifierStyle m
forall (m :: * -> *). TokenParsing m => IdentifierStyle m
emptyOps
, _styleLetter :: m Char
_styleLetter = String -> m Char
forall (m :: * -> *). CharParsing m => String -> m Char
oneOf String
":!#$%&*+./<=>?@\\^|-~"
, _styleReserved :: HashSet String
_styleReserved = HashSet String
forall a. Monoid a => a
mempty
, _styleHighlight :: Highlight
_styleHighlight = Highlight
Operator
, _styleReservedHighlight :: Highlight
_styleReservedHighlight = Highlight
ReservedOperator
}
haskell98Ops, haskellOps :: TokenParsing m => IdentifierStyle m
haskell98Ops :: IdentifierStyle m
haskell98Ops = IdentifierStyle m
forall (m :: * -> *). TokenParsing m => IdentifierStyle m
emptyOps
{ _styleReserved :: HashSet String
_styleReserved = [String] -> HashSet String
set [String
"::",String
"..",String
"=",String
"\\",String
"|",String
"<-",String
"->",String
"@",String
"~",String
"=>"]
}
haskellOps :: IdentifierStyle m
haskellOps = IdentifierStyle m
forall (m :: * -> *). TokenParsing m => IdentifierStyle m
haskell98Ops
emptyIdents :: TokenParsing m => IdentifierStyle m
emptyIdents :: IdentifierStyle m
emptyIdents = IdentifierStyle :: forall (m :: * -> *).
String
-> m Char
-> m Char
-> HashSet String
-> Highlight
-> Highlight
-> IdentifierStyle m
IdentifierStyle
{ _styleName :: String
_styleName = String
"identifier"
, _styleStart :: m Char
_styleStart = m Char
forall (m :: * -> *). CharParsing m => m Char
letter 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
'_'
, _styleLetter :: m Char
_styleLetter = m Char
forall (m :: * -> *). CharParsing m => m Char
alphaNum m Char -> m Char -> m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> m Char
forall (m :: * -> *). CharParsing m => String -> m Char
oneOf String
"_'"
, _styleReserved :: HashSet String
_styleReserved = [String] -> HashSet String
set []
, _styleHighlight :: Highlight
_styleHighlight = Highlight
Identifier
, _styleReservedHighlight :: Highlight
_styleReservedHighlight = Highlight
ReservedIdentifier
}
haskell98Idents :: TokenParsing m => IdentifierStyle m
haskell98Idents :: IdentifierStyle m
haskell98Idents = IdentifierStyle m
forall (m :: * -> *). TokenParsing m => IdentifierStyle m
emptyIdents
{ _styleReserved :: HashSet String
_styleReserved = [String] -> HashSet String
set [String]
haskell98ReservedIdents }
haskellIdents :: TokenParsing m => IdentifierStyle m
haskellIdents :: IdentifierStyle m
haskellIdents = IdentifierStyle m
forall (m :: * -> *). TokenParsing m => IdentifierStyle m
haskell98Idents
{ _styleLetter :: m Char
_styleLetter = IdentifierStyle m -> m Char
forall (m :: * -> *). IdentifierStyle m -> m Char
_styleLetter IdentifierStyle m
forall (m :: * -> *). TokenParsing m => IdentifierStyle m
haskell98Idents 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 = [String] -> HashSet String
set ([String] -> HashSet String) -> [String] -> HashSet String
forall a b. (a -> b) -> a -> b
$ [String]
haskell98ReservedIdents [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
[String
"foreign",String
"import",String
"export",String
"primitive",String
"_ccall_",String
"_casm_" ,String
"forall"]
}
haskell98ReservedIdents :: [String]
haskell98ReservedIdents :: [String]
haskell98ReservedIdents =
[String
"let",String
"in",String
"case",String
"of",String
"if",String
"then",String
"else",String
"data",String
"type"
,String
"class",String
"default",String
"deriving",String
"do",String
"import",String
"infix"
,String
"infixl",String
"infixr",String
"instance",String
"module",String
"newtype"
,String
"where",String
"primitive"
]