{-# 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 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
f :: String -> f String
f (CommentStyle s :: String
s e :: String
e l :: String
l n :: Bool
n) = (\s' :: 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
f :: String -> f String
f (CommentStyle s :: String
s e :: String
e l :: String
l n :: Bool
n) = (\e' :: 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
f :: String -> f String
f (CommentStyle s :: String
s e :: String
e l :: String
l n :: Bool
n) = (\l' :: 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
f :: Bool -> f Bool
f (CommentStyle s :: String
s e :: String
e l :: String
l n :: 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 "" "" "" Bool
True
javaCommentStyle :: CommentStyle
= String -> String -> String -> Bool -> CommentStyle
CommentStyle "/*" "*/" "//" Bool
False
scalaCommentStyle :: CommentStyle
= String -> String -> String -> Bool -> CommentStyle
CommentStyle "/*" "*/" "//" Bool
True
haskellCommentStyle :: CommentStyle
= String -> String -> String -> Bool -> CommentStyle
CommentStyle "{-" "-}" "--" Bool
True
buildSomeSpaceParser :: forall m. CharParsing m => m () -> CommentStyle -> m ()
buildSomeSpaceParser :: m () -> CommentStyle -> m ()
buildSomeSpaceParser simpleSpace :: m ()
simpleSpace (CommentStyle startStyle :: String
startStyle endStyle :: String
endStyle lineStyle :: String
lineStyle nestingStyle :: 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
<?> "")
| 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
<?> "")
| 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
<?> "")
| 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
<?> "")
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
/= '\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 b. Functor f => a -> f b -> f a
<$ 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
<?> "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 b. Functor f => a -> f b -> f a
<$ 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
<?> "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 = "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 ":!#$%&*+./<=>?@\\^|-~"
, _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 ["::","..","=","\\","|","<-","->","@","~","=>"]
}
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 = "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 '_'
, _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 "_'"
, _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 '#'
, _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]
++
["foreign","import","export","primitive","_ccall_","_casm_" ,"forall"]
}
haskell98ReservedIdents :: [String]
haskell98ReservedIdents :: [String]
haskell98ReservedIdents =
["let","in","case","of","if","then","else","data","type"
,"class","default","deriving","do","import","infix"
,"infixl","infixr","instance","module","newtype"
,"where","primitive"
]