module Text.Parser.Token.Style
(
CommentStyle(..)
, emptyCommentStyle
, javaCommentStyle
, haskellCommentStyle
, buildSomeSpaceParser
, emptyIdents, haskellIdents, haskell98Idents
, emptyOps, haskellOps, haskell98Ops
) where
import Control.Applicative
import qualified Data.HashSet as HashSet
import Data.HashSet (HashSet)
import Data.Monoid
import Text.Parser.Combinators
import Text.Parser.Char
import Text.Parser.Token
import Data.List (nub)
data CommentStyle = CommentStyle
{ commentStart :: String
, commentEnd :: String
, commentLine :: String
, commentNesting :: Bool
}
emptyCommentStyle, javaCommentStyle, haskellCommentStyle :: CommentStyle
emptyCommentStyle = CommentStyle "" "" "" True
javaCommentStyle = CommentStyle "/*" "*/" "//" True
haskellCommentStyle = CommentStyle "{-" "-}" "--" True
buildSomeSpaceParser :: CharParsing m => m () -> CommentStyle -> m ()
buildSomeSpaceParser simpleSpace (CommentStyle startStyle endStyle lineStyle nestingStyle)
| noLine && noMulti = skipSome (simpleSpace <?> "")
| noLine = skipSome (simpleSpace <|> multiLineComment <?> "")
| noMulti = skipSome (simpleSpace <|> oneLineComment <?> "")
| otherwise = skipSome (simpleSpace <|> oneLineComment <|> multiLineComment <?> "")
where
noLine = null lineStyle
noMulti = null startStyle
oneLineComment = try (string lineStyle) *> skipMany (satisfy (/= '\n'))
multiLineComment = try (string startStyle) *> inComment
inComment = if nestingStyle then inCommentMulti else inCommentSingle
inCommentMulti
= () <$ try (string endStyle)
<|> multiLineComment *> inCommentMulti
<|> skipSome (noneOf startEnd) *> inCommentMulti
<|> oneOf startEnd *> inCommentMulti
<?> "end of comment"
startEnd = nub (endStyle ++ startStyle)
inCommentSingle
= () <$ try (string endStyle)
<|> skipSome (noneOf startEnd) *> inCommentSingle
<|> oneOf startEnd *> inCommentSingle
<?> "end of comment"
set :: [String] -> HashSet String
set = HashSet.fromList
emptyOps, haskell98Ops, haskellOps :: TokenParsing m => IdentifierStyle m
emptyOps = IdentifierStyle
{ styleName = "operator"
, styleStart = styleLetter emptyOps
, styleLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
, styleReserved = mempty
}
haskell98Ops = emptyOps
{ styleReserved = set ["::","..","=","\\","|","<-","->","@","~","=>"]
}
haskellOps = haskell98Ops
emptyIdents, haskell98Idents, haskellIdents :: TokenParsing m => IdentifierStyle m
emptyIdents = IdentifierStyle
{ styleName = "identifier"
, styleStart = letter <|> char '_'
, styleLetter = alphaNum <|> oneOf "_'"
, styleReserved = set []
}
haskell98Idents = emptyIdents
{ styleReserved = set haskell98ReservedIdents }
haskellIdents = haskell98Idents
{ styleLetter = styleLetter haskell98Idents <|> char '#'
, styleReserved = set $ haskell98ReservedIdents ++
["foreign","import","export","primitive","_ccall_","_casm_" ,"forall"]
}
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"
]