module CHSLexer (CHSToken(..), lexCHS)
where
import Data.List ((\\))
import Data.Char (isDigit)
import Control.Monad (liftM)
import Numeric (readDec, readOct, readHex)
import Position (Position(..), Pos(posOf), incPos, retPos, tabPos)
import Errors (ErrorLvl(..), Error, makeError)
import UNames (NameSupply, Name, names)
import Idents (Ident, lexemeToIdent, identToLexeme)
import Lexers (Regexp, Lexer, Action, epsilon, char, (+>), lexaction,
lexactionErr, lexmeta, (>|<), (>||<), ctrlLexer, star, plus,
quest, alt, string, LexerState, execLexer)
import C2HSState (CST, raise, raiseError, nop, getNameSupply)
data CHSToken = CHSTokArrow Position
| CHSTokDArrow Position
| CHSTokDot Position
| CHSTokComma Position
| CHSTokEqual Position
| CHSTokMinus Position
| CHSTokStar Position
| CHSTokAmp Position
| CHSTokHat Position
| CHSTokLBrace Position
| CHSTokRBrace Position
| CHSTokLParen Position
| CHSTokRParen Position
| CHSTokEndHook Position
| CHSTokAs Position
| CHSTokCall Position
| CHSTokClass Position
| CHSTokContext Position
| CHSTokDerive Position
| CHSTokEnum Position
| CHSTokForeign Position
| CHSTokFun Position
| CHSTokGet Position
| CHSTokImport Position
| CHSTokLib Position
| CHSTokNewtype Position
| CHSTokPointer Position
| CHSTokPrefix Position
| CHSTokPure Position
| CHSTokQualif Position
| CHSTokSet Position
| CHSTokSizeof Position
| CHSTokStable Position
| CHSTokType Position
| CHSTok_2Case Position
| CHSTokUnsafe Position
| CHSTokWith Position
| CHSTokLock Position
| CHSTokNolock Position
| CHSTokString Position String
| CHSTokHSVerb Position String
| CHSTokIdent Position Ident
| CHSTokHaskell Position String
| CHSTokCPP Position String
| CHSTokLine Position
| CHSTokC Position String
| CHSTokCtrl Position Char
| CHSTokPragma Position
| CHSTokPragEnd Position
instance Pos CHSToken where
posOf :: CHSToken -> Position
posOf (CHSTokArrow Position
pos ) = Position
pos
posOf (CHSTokDArrow Position
pos ) = Position
pos
posOf (CHSTokDot Position
pos ) = Position
pos
posOf (CHSTokComma Position
pos ) = Position
pos
posOf (CHSTokEqual Position
pos ) = Position
pos
posOf (CHSTokMinus Position
pos ) = Position
pos
posOf (CHSTokStar Position
pos ) = Position
pos
posOf (CHSTokAmp Position
pos ) = Position
pos
posOf (CHSTokHat Position
pos ) = Position
pos
posOf (CHSTokLBrace Position
pos ) = Position
pos
posOf (CHSTokRBrace Position
pos ) = Position
pos
posOf (CHSTokLParen Position
pos ) = Position
pos
posOf (CHSTokRParen Position
pos ) = Position
pos
posOf (CHSTokEndHook Position
pos ) = Position
pos
posOf (CHSTokAs Position
pos ) = Position
pos
posOf (CHSTokCall Position
pos ) = Position
pos
posOf (CHSTokClass Position
pos ) = Position
pos
posOf (CHSTokContext Position
pos ) = Position
pos
posOf (CHSTokDerive Position
pos ) = Position
pos
posOf (CHSTokEnum Position
pos ) = Position
pos
posOf (CHSTokForeign Position
pos ) = Position
pos
posOf (CHSTokFun Position
pos ) = Position
pos
posOf (CHSTokGet Position
pos ) = Position
pos
posOf (CHSTokImport Position
pos ) = Position
pos
posOf (CHSTokLib Position
pos ) = Position
pos
posOf (CHSTokNewtype Position
pos ) = Position
pos
posOf (CHSTokPointer Position
pos ) = Position
pos
posOf (CHSTokPrefix Position
pos ) = Position
pos
posOf (CHSTokPure Position
pos ) = Position
pos
posOf (CHSTokQualif Position
pos ) = Position
pos
posOf (CHSTokSet Position
pos ) = Position
pos
posOf (CHSTokSizeof Position
pos ) = Position
pos
posOf (CHSTokStable Position
pos ) = Position
pos
posOf (CHSTokType Position
pos ) = Position
pos
posOf (CHSTok_2Case Position
pos ) = Position
pos
posOf (CHSTokUnsafe Position
pos ) = Position
pos
posOf (CHSTokWith Position
pos ) = Position
pos
posOf (CHSTokLock Position
pos ) = Position
pos
posOf (CHSTokNolock Position
pos ) = Position
pos
posOf (CHSTokString Position
pos String
_) = Position
pos
posOf (CHSTokHSVerb Position
pos String
_) = Position
pos
posOf (CHSTokIdent Position
pos Ident
_) = Position
pos
posOf (CHSTokHaskell Position
pos String
_) = Position
pos
posOf (CHSTokCPP Position
pos String
_) = Position
pos
posOf (CHSTokC Position
pos String
_) = Position
pos
posOf (CHSTokCtrl Position
pos Char
_) = Position
pos
posOf (CHSTokPragma Position
pos ) = Position
pos
posOf (CHSTokPragEnd Position
pos ) = Position
pos
instance Eq CHSToken where
(CHSTokArrow Position
_ ) == :: CHSToken -> CHSToken -> Bool
== (CHSTokArrow Position
_ ) = Bool
True
(CHSTokDArrow Position
_ ) == (CHSTokDArrow Position
_ ) = Bool
True
(CHSTokDot Position
_ ) == (CHSTokDot Position
_ ) = Bool
True
(CHSTokComma Position
_ ) == (CHSTokComma Position
_ ) = Bool
True
(CHSTokEqual Position
_ ) == (CHSTokEqual Position
_ ) = Bool
True
(CHSTokMinus Position
_ ) == (CHSTokMinus Position
_ ) = Bool
True
(CHSTokStar Position
_ ) == (CHSTokStar Position
_ ) = Bool
True
(CHSTokAmp Position
_ ) == (CHSTokAmp Position
_ ) = Bool
True
(CHSTokHat Position
_ ) == (CHSTokHat Position
_ ) = Bool
True
(CHSTokLBrace Position
_ ) == (CHSTokLBrace Position
_ ) = Bool
True
(CHSTokRBrace Position
_ ) == (CHSTokRBrace Position
_ ) = Bool
True
(CHSTokLParen Position
_ ) == (CHSTokLParen Position
_ ) = Bool
True
(CHSTokRParen Position
_ ) == (CHSTokRParen Position
_ ) = Bool
True
(CHSTokEndHook Position
_ ) == (CHSTokEndHook Position
_ ) = Bool
True
(CHSTokAs Position
_ ) == (CHSTokAs Position
_ ) = Bool
True
(CHSTokCall Position
_ ) == (CHSTokCall Position
_ ) = Bool
True
(CHSTokClass Position
_ ) == (CHSTokClass Position
_ ) = Bool
True
(CHSTokContext Position
_ ) == (CHSTokContext Position
_ ) = Bool
True
(CHSTokDerive Position
_ ) == (CHSTokDerive Position
_ ) = Bool
True
(CHSTokEnum Position
_ ) == (CHSTokEnum Position
_ ) = Bool
True
(CHSTokForeign Position
_ ) == (CHSTokForeign Position
_ ) = Bool
True
(CHSTokFun Position
_ ) == (CHSTokFun Position
_ ) = Bool
True
(CHSTokGet Position
_ ) == (CHSTokGet Position
_ ) = Bool
True
(CHSTokImport Position
_ ) == (CHSTokImport Position
_ ) = Bool
True
(CHSTokLib Position
_ ) == (CHSTokLib Position
_ ) = Bool
True
(CHSTokNewtype Position
_ ) == (CHSTokNewtype Position
_ ) = Bool
True
(CHSTokPointer Position
_ ) == (CHSTokPointer Position
_ ) = Bool
True
(CHSTokPrefix Position
_ ) == (CHSTokPrefix Position
_ ) = Bool
True
(CHSTokPure Position
_ ) == (CHSTokPure Position
_ ) = Bool
True
(CHSTokQualif Position
_ ) == (CHSTokQualif Position
_ ) = Bool
True
(CHSTokSet Position
_ ) == (CHSTokSet Position
_ ) = Bool
True
(CHSTokSizeof Position
_ ) == (CHSTokSizeof Position
_ ) = Bool
True
(CHSTokStable Position
_ ) == (CHSTokStable Position
_ ) = Bool
True
(CHSTokType Position
_ ) == (CHSTokType Position
_ ) = Bool
True
(CHSTok_2Case Position
_ ) == (CHSTok_2Case Position
_ ) = Bool
True
(CHSTokUnsafe Position
_ ) == (CHSTokUnsafe Position
_ ) = Bool
True
(CHSTokWith Position
_ ) == (CHSTokWith Position
_ ) = Bool
True
(CHSTokLock Position
_ ) == (CHSTokLock Position
_ ) = Bool
True
(CHSTokNolock Position
_ ) == (CHSTokNolock Position
_ ) = Bool
True
(CHSTokString Position
_ String
_) == (CHSTokString Position
_ String
_) = Bool
True
(CHSTokHSVerb Position
_ String
_) == (CHSTokHSVerb Position
_ String
_) = Bool
True
(CHSTokIdent Position
_ Ident
_) == (CHSTokIdent Position
_ Ident
_) = Bool
True
(CHSTokHaskell Position
_ String
_) == (CHSTokHaskell Position
_ String
_) = Bool
True
(CHSTokCPP Position
_ String
_) == (CHSTokCPP Position
_ String
_) = Bool
True
(CHSTokC Position
_ String
_) == (CHSTokC Position
_ String
_) = Bool
True
(CHSTokCtrl Position
_ Char
_) == (CHSTokCtrl Position
_ Char
_) = Bool
True
(CHSTokPragma Position
_ ) == (CHSTokPragma Position
_ ) = Bool
True
(CHSTokPragEnd Position
_ ) == (CHSTokPragEnd Position
_ ) = Bool
True
CHSToken
_ == CHSToken
_ = Bool
False
instance Show CHSToken where
showsPrec :: Int -> CHSToken -> ShowS
showsPrec Int
_ (CHSTokArrow Position
_ ) = String -> ShowS
showString String
"->"
showsPrec Int
_ (CHSTokDArrow Position
_ ) = String -> ShowS
showString String
"=>"
showsPrec Int
_ (CHSTokDot Position
_ ) = String -> ShowS
showString String
"."
showsPrec Int
_ (CHSTokComma Position
_ ) = String -> ShowS
showString String
","
showsPrec Int
_ (CHSTokEqual Position
_ ) = String -> ShowS
showString String
"="
showsPrec Int
_ (CHSTokMinus Position
_ ) = String -> ShowS
showString String
"-"
showsPrec Int
_ (CHSTokStar Position
_ ) = String -> ShowS
showString String
"*"
showsPrec Int
_ (CHSTokAmp Position
_ ) = String -> ShowS
showString String
"&"
showsPrec Int
_ (CHSTokHat Position
_ ) = String -> ShowS
showString String
"^"
showsPrec Int
_ (CHSTokLBrace Position
_ ) = String -> ShowS
showString String
"{"
showsPrec Int
_ (CHSTokRBrace Position
_ ) = String -> ShowS
showString String
"}"
showsPrec Int
_ (CHSTokLParen Position
_ ) = String -> ShowS
showString String
"("
showsPrec Int
_ (CHSTokRParen Position
_ ) = String -> ShowS
showString String
")"
showsPrec Int
_ (CHSTokEndHook Position
_ ) = String -> ShowS
showString String
"#}"
showsPrec Int
_ (CHSTokAs Position
_ ) = String -> ShowS
showString String
"as"
showsPrec Int
_ (CHSTokCall Position
_ ) = String -> ShowS
showString String
"call"
showsPrec Int
_ (CHSTokClass Position
_ ) = String -> ShowS
showString String
"class"
showsPrec Int
_ (CHSTokContext Position
_ ) = String -> ShowS
showString String
"context"
showsPrec Int
_ (CHSTokDerive Position
_ ) = String -> ShowS
showString String
"deriving"
showsPrec Int
_ (CHSTokEnum Position
_ ) = String -> ShowS
showString String
"enum"
showsPrec Int
_ (CHSTokForeign Position
_ ) = String -> ShowS
showString String
"foreign"
showsPrec Int
_ (CHSTokFun Position
_ ) = String -> ShowS
showString String
"fun"
showsPrec Int
_ (CHSTokGet Position
_ ) = String -> ShowS
showString String
"get"
showsPrec Int
_ (CHSTokImport Position
_ ) = String -> ShowS
showString String
"import"
showsPrec Int
_ (CHSTokLib Position
_ ) = String -> ShowS
showString String
"lib"
showsPrec Int
_ (CHSTokNewtype Position
_ ) = String -> ShowS
showString String
"newtype"
showsPrec Int
_ (CHSTokPointer Position
_ ) = String -> ShowS
showString String
"pointer"
showsPrec Int
_ (CHSTokPrefix Position
_ ) = String -> ShowS
showString String
"prefix"
showsPrec Int
_ (CHSTokPure Position
_ ) = String -> ShowS
showString String
"pure"
showsPrec Int
_ (CHSTokQualif Position
_ ) = String -> ShowS
showString String
"qualified"
showsPrec Int
_ (CHSTokSet Position
_ ) = String -> ShowS
showString String
"set"
showsPrec Int
_ (CHSTokSizeof Position
_ ) = String -> ShowS
showString String
"sizeof"
showsPrec Int
_ (CHSTokStable Position
_ ) = String -> ShowS
showString String
"stable"
showsPrec Int
_ (CHSTokType Position
_ ) = String -> ShowS
showString String
"type"
showsPrec Int
_ (CHSTok_2Case Position
_ ) = String -> ShowS
showString String
"underscoreToCase"
showsPrec Int
_ (CHSTokUnsafe Position
_ ) = String -> ShowS
showString String
"unsafe"
showsPrec Int
_ (CHSTokWith Position
_ ) = String -> ShowS
showString String
"with"
showsPrec Int
_ (CHSTokLock Position
_ ) = String -> ShowS
showString String
"lock"
showsPrec Int
_ (CHSTokNolock Position
_ ) = String -> ShowS
showString String
"nolock"
showsPrec Int
_ (CHSTokString Position
_ String
s) = String -> ShowS
showString (String
"\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\"")
showsPrec Int
_ (CHSTokHSVerb Position
_ String
s) = String -> ShowS
showString (String
"`" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'")
showsPrec Int
_ (CHSTokIdent Position
_ Ident
i) = (String -> ShowS
showString (String -> ShowS) -> (Ident -> String) -> Ident -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> String
identToLexeme) Ident
i
showsPrec Int
_ (CHSTokHaskell Position
_ String
s) = String -> ShowS
showString String
s
showsPrec Int
_ (CHSTokCPP Position
_ String
s) = String -> ShowS
showString String
s
showsPrec Int
_ (CHSTokC Position
_ String
s) = String -> ShowS
showString String
s
showsPrec Int
_ (CHSTokCtrl Position
_ Char
c) = Char -> ShowS
showChar Char
c
showsPrec Int
_ (CHSTokPragma Position
_ ) = String -> ShowS
showString String
"{-# LANGUAGE"
showsPrec Int
_ (CHSTokPragEnd Position
_ ) = String -> ShowS
showString String
"#-}"
data CHSLexerState = CHSLS {
CHSLexerState -> Int
nestLvl :: Int,
CHSLexerState -> Bool
inHook :: Bool,
CHSLexerState -> [Name]
namesup :: [Name]
}
initialState :: CST s CHSLexerState
initialState :: CST s CHSLexerState
initialState = do
[Name]
namesup <- (NameSupply -> [Name])
-> PreCST SwitchBoard s NameSupply -> PreCST SwitchBoard s [Name]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM NameSupply -> [Name]
names PreCST SwitchBoard s NameSupply
forall e s. PreCST e s NameSupply
getNameSupply
CHSLexerState -> CST s CHSLexerState
forall (m :: * -> *) a. Monad m => a -> m a
return (CHSLexerState -> CST s CHSLexerState)
-> CHSLexerState -> CST s CHSLexerState
forall a b. (a -> b) -> a -> b
$ CHSLS :: Int -> Bool -> [Name] -> CHSLexerState
CHSLS {
nestLvl :: Int
nestLvl = Int
0,
inHook :: Bool
inHook = Bool
False,
namesup :: [Name]
namesup = [Name]
namesup
}
assertFinalState :: Position -> CHSLexerState -> CST s ()
assertFinalState :: Position -> CHSLexerState -> CST s ()
assertFinalState Position
pos CHSLS {nestLvl :: CHSLexerState -> Int
nestLvl = Int
nestLvl, inHook :: CHSLexerState -> Bool
inHook = Bool
inHook}
| Int
nestLvl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Position -> [String] -> CST s ()
forall e s. Position -> [String] -> PreCST e s ()
raiseError Position
pos [String
"Unexpected end of file!",
String
"Unclosed nested comment."]
| Bool
inHook = Position -> [String] -> CST s ()
forall e s. Position -> [String] -> PreCST e s ()
raiseError Position
pos [String
"Unexpected end of file!",
String
"Unclosed binding hook."]
| Bool
otherwise = CST s ()
forall e s. PreCST e s ()
nop
type CHSLexer = Lexer CHSLexerState CHSToken
type CHSAction = Action CHSToken
type CHSRegexp = Regexp CHSLexerState CHSToken
infixl 3 `lexactionName`
lexactionName :: CHSRegexp
-> (String -> Position -> Name -> CHSToken)
-> CHSLexer
CHSRegexp
re lexactionName :: CHSRegexp -> (String -> Position -> Name -> CHSToken) -> CHSLexer
`lexactionName` String -> Position -> Name -> CHSToken
action = CHSRegexp
re CHSRegexp -> Meta CHSLexerState CHSToken -> CHSLexer
forall s t. Regexp s t -> Meta s t -> Lexer s t
`lexmeta` Meta CHSLexerState CHSToken
forall a a.
String
-> Position
-> CHSLexerState
-> (Maybe (Either a CHSToken), Position, CHSLexerState, Maybe a)
action'
where
action' :: String
-> Position
-> CHSLexerState
-> (Maybe (Either a CHSToken), Position, CHSLexerState, Maybe a)
action' String
str Position
pos CHSLexerState
state = let Name
name:[Name]
ns = CHSLexerState -> [Name]
namesup CHSLexerState
state
in
(Either a CHSToken -> Maybe (Either a CHSToken)
forall a. a -> Maybe a
Just (Either a CHSToken -> Maybe (Either a CHSToken))
-> Either a CHSToken -> Maybe (Either a CHSToken)
forall a b. (a -> b) -> a -> b
$ CHSToken -> Either a CHSToken
forall a b. b -> Either a b
Right (String -> Position -> Name -> CHSToken
action String
str Position
pos Name
name),
Position -> Int -> Position
incPos Position
pos (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str),
CHSLexerState
state {namesup :: [Name]
namesup = [Name]
ns},
Maybe a
forall a. Maybe a
Nothing)
chslexer :: CHSLexer
chslexer :: CHSLexer
chslexer = CHSLexer
pragma
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< CHSLexer
haskell
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< CHSLexer
nested
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< CHSLexer
ctrl
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< CHSLexer
hook
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< CHSLexer
cpp
pragma :: CHSLexer
pragma :: CHSLexer
pragma = String -> CHSRegexp
forall s t. String -> Regexp s t
string String
"{-# LANGUAGE" CHSRegexp -> Meta CHSLexerState CHSToken -> CHSLexer
forall s t. Regexp s t -> Meta s t -> Lexer s t
`lexmeta` \String
_ Position
pos CHSLexerState
s ->
(Either Error CHSToken -> Maybe (Either Error CHSToken)
forall a. a -> Maybe a
Just (Either Error CHSToken -> Maybe (Either Error CHSToken))
-> Either Error CHSToken -> Maybe (Either Error CHSToken)
forall a b. (a -> b) -> a -> b
$ CHSToken -> Either Error CHSToken
forall a b. b -> Either a b
Right (Position -> CHSToken
CHSTokPragma Position
pos), Position -> Int -> Position
incPos Position
pos Int
12, CHSLexerState
s, CHSLexer -> Maybe CHSLexer
forall a. a -> Maybe a
Just CHSLexer
langLexer)
langLexer :: CHSLexer
langLexer :: CHSLexer
langLexer = CHSLexer
whitespace CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< CHSLexer
identOrKW CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< CHSLexer
symbol CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||<
(String -> CHSRegexp
forall s t. String -> Regexp s t
string String
"#-}" CHSRegexp -> Meta CHSLexerState CHSToken -> CHSLexer
forall s t. Regexp s t -> Meta s t -> Lexer s t
`lexmeta` \String
_ Position
pos CHSLexerState
s ->
(Either Error CHSToken -> Maybe (Either Error CHSToken)
forall a. a -> Maybe a
Just (Either Error CHSToken -> Maybe (Either Error CHSToken))
-> Either Error CHSToken -> Maybe (Either Error CHSToken)
forall a b. (a -> b) -> a -> b
$ CHSToken -> Either Error CHSToken
forall a b. b -> Either a b
Right (Position -> CHSToken
CHSTokPragEnd Position
pos), Position -> Int -> Position
incPos Position
pos Int
3, CHSLexerState
s, CHSLexer -> Maybe CHSLexer
forall a. a -> Maybe a
Just CHSLexer
chslexer))
haskell :: CHSLexer
haskell :: CHSLexer
haskell = ( CHSRegexp
forall s t. Regexp s t
anyButSpecialCHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
`star` CHSRegexp
forall s t. Regexp s t
epsilon
CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
>|< CHSRegexp
forall s t. Regexp s t
specialButQuotes
CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
>|< Char -> CHSRegexp
forall s t. Char -> Regexp s t
char Char
'"' CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
+> CHSRegexp
forall s t. Regexp s t
inhstrCHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
`star` Char -> CHSRegexp
forall s t. Char -> Regexp s t
char Char
'"'
CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
>|< String -> CHSRegexp
forall s t. String -> Regexp s t
string String
"'\"'"
CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
>|< String -> CHSRegexp
forall s t. String -> Regexp s t
string String
"--" CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
+> CHSRegexp
forall s t. Regexp s t
anyButNLCHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
`star` CHSRegexp
forall s t. Regexp s t
epsilon
)
CHSRegexp -> Action CHSToken -> CHSLexer
forall s t. Regexp s t -> Action t -> Lexer s t
`lexaction` Action CHSToken
copyVerbatim
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< Char -> CHSRegexp
forall s t. Char -> Regexp s t
char Char
'"'
CHSRegexp -> ActionErr CHSToken -> CHSLexer
forall s t. Regexp s t -> ActionErr t -> Lexer s t
`lexactionErr`
\String
_ Position
pos -> (Error -> Either Error CHSToken
forall a b. a -> Either a b
Left (Error -> Either Error CHSToken) -> Error -> Either Error CHSToken
forall a b. (a -> b) -> a -> b
$ ErrorLvl -> Position -> [String] -> Error
makeError ErrorLvl
ErrorErr Position
pos
[String
"Lexical error!",
String
"Unclosed string."])
where
anyButSpecial :: Regexp s t
anyButSpecial = String -> Regexp s t
forall s t. String -> Regexp s t
alt (String
inlineSet String -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ String
specialSet)
specialButQuotes :: Regexp s t
specialButQuotes = String -> Regexp s t
forall s t. String -> Regexp s t
alt (String
specialSet String -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ [Char
'"'])
anyButNL :: Regexp s t
anyButNL = String -> Regexp s t
forall s t. String -> Regexp s t
alt (String
anySet String -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ [Char
'\n'])
inhstr :: Regexp s t
inhstr = Regexp s t
forall s t. Regexp s t
instr Regexp s t -> Regexp s t -> Regexp s t
forall s t. Regexp s t -> Regexp s t -> Regexp s t
>|< Char -> Regexp s t
forall s t. Char -> Regexp s t
char Char
'\\' Regexp s t -> Regexp s t -> Regexp s t
forall s t. Regexp s t -> Regexp s t -> Regexp s t
>|< String -> Regexp s t
forall s t. String -> Regexp s t
string String
"\\\"" Regexp s t -> Regexp s t -> Regexp s t
forall s t. Regexp s t -> Regexp s t -> Regexp s t
>|< Regexp s t
forall s t. Regexp s t
gap
gap :: Regexp s t
gap = Char -> Regexp s t
forall s t. Char -> Regexp s t
char Char
'\\' Regexp s t -> Regexp s t -> Regexp s t
forall s t. Regexp s t -> Regexp s t -> Regexp s t
+> String -> Regexp s t
forall s t. String -> Regexp s t
alt (Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:String
ctrlSet)Regexp s t -> Regexp s t -> Regexp s t
forall s t. Regexp s t -> Regexp s t -> Regexp s t
`plus` Char -> Regexp s t
forall s t. Char -> Regexp s t
char Char
'\\'
copyVerbatim :: CHSAction
copyVerbatim :: Action CHSToken
copyVerbatim String
cs Position
pos = CHSToken -> Maybe CHSToken
forall a. a -> Maybe a
Just (CHSToken -> Maybe CHSToken) -> CHSToken -> Maybe CHSToken
forall a b. (a -> b) -> a -> b
$ Position -> String -> CHSToken
CHSTokHaskell Position
pos String
cs
nested :: CHSLexer
nested :: CHSLexer
nested =
String -> CHSRegexp
forall s t. String -> Regexp s t
string String
"{-"
CHSRegexp -> Meta CHSLexerState CHSToken -> CHSLexer
forall s t. Regexp s t -> Meta s t -> Lexer s t
`lexmeta` Meta CHSLexerState CHSToken
forall a.
String
-> Position
-> CHSLexerState
-> (Maybe (Either a CHSToken), Position, CHSLexerState,
Maybe CHSLexer)
enterComment
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||<
String -> CHSRegexp
forall s t. String -> Regexp s t
string String
"-}"
CHSRegexp -> Meta CHSLexerState CHSToken -> CHSLexer
forall s t. Regexp s t -> Meta s t -> Lexer s t
`lexmeta` Meta CHSLexerState CHSToken
leaveComment
where
enterComment :: String
-> Position
-> CHSLexerState
-> (Maybe (Either a CHSToken), Position, CHSLexerState,
Maybe CHSLexer)
enterComment String
cs Position
pos CHSLexerState
s =
(String -> Position -> Maybe (Either a CHSToken)
forall a. String -> Position -> Maybe (Either a CHSToken)
copyVerbatim' String
cs Position
pos,
Position -> Int -> Position
incPos Position
pos Int
2,
CHSLexerState
s {nestLvl :: Int
nestLvl = CHSLexerState -> Int
nestLvl CHSLexerState
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1},
CHSLexer -> Maybe CHSLexer
forall a. a -> Maybe a
Just (CHSLexer -> Maybe CHSLexer) -> CHSLexer -> Maybe CHSLexer
forall a b. (a -> b) -> a -> b
$ CHSLexer
inNestedComment)
leaveComment :: Meta CHSLexerState CHSToken
leaveComment String
cs Position
pos CHSLexerState
s =
case CHSLexerState -> Int
nestLvl CHSLexerState
s of
Int
0 -> (Position -> Maybe (Either Error CHSToken)
forall b. Position -> Maybe (Either Error b)
commentCloseErr Position
pos,
Position -> Int -> Position
incPos Position
pos Int
2,
CHSLexerState
s,
Maybe CHSLexer
forall a. Maybe a
Nothing)
Int
1 -> (String -> Position -> Maybe (Either Error CHSToken)
forall a. String -> Position -> Maybe (Either a CHSToken)
copyVerbatim' String
cs Position
pos,
Position -> Int -> Position
incPos Position
pos Int
2,
CHSLexerState
s {nestLvl :: Int
nestLvl = CHSLexerState -> Int
nestLvl CHSLexerState
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1},
CHSLexer -> Maybe CHSLexer
forall a. a -> Maybe a
Just CHSLexer
chslexer)
Int
_ -> (String -> Position -> Maybe (Either Error CHSToken)
forall a. String -> Position -> Maybe (Either a CHSToken)
copyVerbatim' String
cs Position
pos,
Position -> Int -> Position
incPos Position
pos Int
2,
CHSLexerState
s {nestLvl :: Int
nestLvl = CHSLexerState -> Int
nestLvl CHSLexerState
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1},
Maybe CHSLexer
forall a. Maybe a
Nothing)
copyVerbatim' :: String -> Position -> Maybe (Either a CHSToken)
copyVerbatim' String
cs Position
pos = Either a CHSToken -> Maybe (Either a CHSToken)
forall a. a -> Maybe a
Just (Either a CHSToken -> Maybe (Either a CHSToken))
-> Either a CHSToken -> Maybe (Either a CHSToken)
forall a b. (a -> b) -> a -> b
$ CHSToken -> Either a CHSToken
forall a b. b -> Either a b
Right (Position -> String -> CHSToken
CHSTokHaskell Position
pos String
cs)
commentCloseErr :: Position -> Maybe (Either Error b)
commentCloseErr Position
pos =
Either Error b -> Maybe (Either Error b)
forall a. a -> Maybe a
Just (Either Error b -> Maybe (Either Error b))
-> Either Error b -> Maybe (Either Error b)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error b
forall a b. a -> Either a b
Left (ErrorLvl -> Position -> [String] -> Error
makeError ErrorLvl
ErrorErr Position
pos
[String
"Lexical error!",
String
"`-}' not preceded by a matching `{-'."])
inNestedComment :: CHSLexer
= CHSLexer
commentInterior
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< CHSLexer
nested
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< CHSLexer
ctrl
commentInterior :: CHSLexer
= ( CHSRegexp
forall s t. Regexp s t
anyButSpecialCHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
`star` CHSRegexp
forall s t. Regexp s t
epsilon
CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
>|< CHSRegexp
forall s t. Regexp s t
special
)
CHSRegexp -> Action CHSToken -> CHSLexer
forall s t. Regexp s t -> Action t -> Lexer s t
`lexaction` Action CHSToken
copyVerbatim
where
anyButSpecial :: Regexp s t
anyButSpecial = String -> Regexp s t
forall s t. String -> Regexp s t
alt (String
inlineSet String -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ String
commentSpecialSet)
special :: Regexp s t
special = String -> Regexp s t
forall s t. String -> Regexp s t
alt String
commentSpecialSet
ctrl :: CHSLexer
ctrl :: CHSLexer
ctrl =
Char -> CHSRegexp
forall s t. Char -> Regexp s t
char Char
'\n' CHSRegexp -> Meta CHSLexerState CHSToken -> CHSLexer
forall s t. Regexp s t -> Meta s t -> Lexer s t
`lexmeta` Meta CHSLexerState CHSToken
forall c a a.
String
-> Position
-> c
-> (Maybe (Either a CHSToken), Position, c, Maybe a)
newline
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< Char -> CHSRegexp
forall s t. Char -> Regexp s t
char Char
'\r' CHSRegexp -> Meta CHSLexerState CHSToken -> CHSLexer
forall s t. Regexp s t -> Meta s t -> Lexer s t
`lexmeta` Meta CHSLexerState CHSToken
forall c a a.
String
-> Position
-> c
-> (Maybe (Either a CHSToken), Position, c, Maybe a)
newline
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< Char -> CHSRegexp
forall s t. Char -> Regexp s t
char Char
'\v' CHSRegexp -> Meta CHSLexerState CHSToken -> CHSLexer
forall s t. Regexp s t -> Meta s t -> Lexer s t
`lexmeta` Meta CHSLexerState CHSToken
forall c a a.
String
-> Position
-> c
-> (Maybe (Either a CHSToken), Position, c, Maybe a)
newline
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< Char -> CHSRegexp
forall s t. Char -> Regexp s t
char Char
'\f' CHSRegexp -> Meta CHSLexerState CHSToken -> CHSLexer
forall s t. Regexp s t -> Meta s t -> Lexer s t
`lexmeta` Meta CHSLexerState CHSToken
forall c a a.
String
-> Position
-> c
-> (Maybe (Either a CHSToken), Position, c, Maybe a)
formfeed
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< Char -> CHSRegexp
forall s t. Char -> Regexp s t
char Char
'\t' CHSRegexp -> Meta CHSLexerState CHSToken -> CHSLexer
forall s t. Regexp s t -> Meta s t -> Lexer s t
`lexmeta` Meta CHSLexerState CHSToken
forall c a a.
String
-> Position
-> c
-> (Maybe (Either a CHSToken), Position, c, Maybe a)
tab
where
newline :: String
-> Position
-> c
-> (Maybe (Either a CHSToken), Position, c, Maybe a)
newline [Char
c] Position
pos = Position
-> Char
-> Position
-> c
-> (Maybe (Either a CHSToken), Position, c, Maybe a)
forall b c a a.
Position
-> Char -> b -> c -> (Maybe (Either a CHSToken), b, c, Maybe a)
ctrlResult Position
pos Char
c (Position -> Position
retPos Position
pos)
formfeed :: String
-> Position
-> c
-> (Maybe (Either a CHSToken), Position, c, Maybe a)
formfeed [Char
c] Position
pos = Position
-> Char
-> Position
-> c
-> (Maybe (Either a CHSToken), Position, c, Maybe a)
forall b c a a.
Position
-> Char -> b -> c -> (Maybe (Either a CHSToken), b, c, Maybe a)
ctrlResult Position
pos Char
c (Position -> Int -> Position
incPos Position
pos Int
1)
tab :: String
-> Position
-> c
-> (Maybe (Either a CHSToken), Position, c, Maybe a)
tab [Char
c] Position
pos = Position
-> Char
-> Position
-> c
-> (Maybe (Either a CHSToken), Position, c, Maybe a)
forall b c a a.
Position
-> Char -> b -> c -> (Maybe (Either a CHSToken), b, c, Maybe a)
ctrlResult Position
pos Char
c (Position -> Position
tabPos Position
pos)
ctrlResult :: Position
-> Char -> b -> c -> (Maybe (Either a CHSToken), b, c, Maybe a)
ctrlResult Position
pos Char
c b
pos' c
s =
(Either a CHSToken -> Maybe (Either a CHSToken)
forall a. a -> Maybe a
Just (Either a CHSToken -> Maybe (Either a CHSToken))
-> Either a CHSToken -> Maybe (Either a CHSToken)
forall a b. (a -> b) -> a -> b
$ CHSToken -> Either a CHSToken
forall a b. b -> Either a b
Right (Position -> Char -> CHSToken
CHSTokCtrl Position
pos Char
c), b
pos', c
s, Maybe a
forall a. Maybe a
Nothing)
hook :: CHSLexer
hook :: CHSLexer
hook = String -> CHSRegexp
forall s t. String -> Regexp s t
string String
"{#"
CHSRegexp -> Meta CHSLexerState CHSToken -> CHSLexer
forall s t. Regexp s t -> Meta s t -> Lexer s t
`lexmeta` \String
_ Position
pos CHSLexerState
s -> (Maybe (Either Error CHSToken)
forall a. Maybe a
Nothing, Position -> Int -> Position
incPos Position
pos Int
2, CHSLexerState
s, CHSLexer -> Maybe CHSLexer
forall a. a -> Maybe a
Just CHSLexer
bhLexer)
cpp :: CHSLexer
cpp :: CHSLexer
cpp = CHSLexer
directive
where
directive :: CHSLexer
directive =
String -> CHSRegexp
forall s t. String -> Regexp s t
string String
"\n#" CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
+> String -> CHSRegexp
forall s t. String -> Regexp s t
alt (Char
'\t'Char -> ShowS
forall a. a -> [a] -> [a]
:String
inlineSet)CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
`star` CHSRegexp
forall s t. Regexp s t
epsilon
CHSRegexp -> Meta CHSLexerState CHSToken -> CHSLexer
forall s t. Regexp s t -> Meta s t -> Lexer s t
`lexmeta`
\(Char
_:Char
_:String
dir) Position
pos CHSLexerState
s ->
case String
dir of
[Char
'c'] ->
(Maybe (Either Error CHSToken)
forall a. Maybe a
Nothing, Position -> Position
retPos Position
pos, CHSLexerState
s, CHSLexer -> Maybe CHSLexer
forall a. a -> Maybe a
Just CHSLexer
cLexer)
Char
'c':Char
sp:String
_ | Char
sp Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
" \t" ->
(Maybe (Either Error CHSToken)
forall a. Maybe a
Nothing, Position -> Position
retPos Position
pos, CHSLexerState
s, CHSLexer -> Maybe CHSLexer
forall a. a -> Maybe a
Just CHSLexer
cLexer)
Char
' ':line :: String
line@(Char
n:String
_) | Char -> Bool
isDigit Char
n ->
let pos' :: Position
pos' = String -> Position -> Position
adjustPosByCLinePragma String
line Position
pos
in (Either Error CHSToken -> Maybe (Either Error CHSToken)
forall a. a -> Maybe a
Just (Either Error CHSToken -> Maybe (Either Error CHSToken))
-> Either Error CHSToken -> Maybe (Either Error CHSToken)
forall a b. (a -> b) -> a -> b
$ CHSToken -> Either Error CHSToken
forall a b. b -> Either a b
Right (Position -> CHSToken
CHSTokLine Position
pos'), Position
pos', CHSLexerState
s, Maybe CHSLexer
forall a. Maybe a
Nothing)
String
_ ->
(Either Error CHSToken -> Maybe (Either Error CHSToken)
forall a. a -> Maybe a
Just (Either Error CHSToken -> Maybe (Either Error CHSToken))
-> Either Error CHSToken -> Maybe (Either Error CHSToken)
forall a b. (a -> b) -> a -> b
$ CHSToken -> Either Error CHSToken
forall a b. b -> Either a b
Right (Position -> String -> CHSToken
CHSTokCPP Position
pos String
dir),
Position -> Position
retPos Position
pos, CHSLexerState
s, Maybe CHSLexer
forall a. Maybe a
Nothing)
adjustPosByCLinePragma :: String -> Position -> Position
adjustPosByCLinePragma :: String -> Position -> Position
adjustPosByCLinePragma String
str (Position String
fname Int
_ Int
_) =
(String -> Int -> Int -> Position
Position String
fname' Int
row' Int
0)
where
str' :: String
str' = ShowS
dropWhite String
str
(String
rowStr, String
str'') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
str'
row' :: Int
row' = String -> Int
forall a. Read a => String -> a
read String
rowStr
str''' :: String
str''' = ShowS
dropWhite String
str''
fnameStr :: String
fnameStr = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
str'''
fname' :: String
fname' | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
str''' Bool -> Bool -> Bool
|| String -> Char
forall a. [a] -> a
head String
str''' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"' = String
fname
| String
fnameStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
fname = String
fname
| Bool
otherwise = String
fnameStr
dropWhite :: ShowS
dropWhite = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t')
bhLexer :: CHSLexer
bhLexer :: CHSLexer
bhLexer = CHSLexer
identOrKW
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< CHSLexer
symbol
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< CHSLexer
strlit
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< CHSLexer
hsverb
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< CHSLexer
whitespace
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< CHSLexer
endOfHook
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< String -> CHSRegexp
forall s t. String -> Regexp s t
string String
"--" CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
+> CHSRegexp
forall s t. Regexp s t
anyButNLCHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
`star` Char -> CHSRegexp
forall s t. Char -> Regexp s t
char Char
'\n'
CHSRegexp -> Meta CHSLexerState CHSToken -> CHSLexer
forall s t. Regexp s t -> Meta s t -> Lexer s t
`lexmeta` \String
_ Position
pos CHSLexerState
s -> (Maybe (Either Error CHSToken)
forall a. Maybe a
Nothing, Position -> Position
retPos Position
pos, CHSLexerState
s, Maybe CHSLexer
forall a. Maybe a
Nothing)
where
anyButNL :: Regexp s t
anyButNL = String -> Regexp s t
forall s t. String -> Regexp s t
alt (String
anySet String -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ [Char
'\n'])
endOfHook :: CHSLexer
endOfHook = String -> CHSRegexp
forall s t. String -> Regexp s t
string String
"#}"
CHSRegexp -> Meta CHSLexerState CHSToken -> CHSLexer
forall s t. Regexp s t -> Meta s t -> Lexer s t
`lexmeta`
\String
_ Position
pos CHSLexerState
s -> (Either Error CHSToken -> Maybe (Either Error CHSToken)
forall a. a -> Maybe a
Just (Either Error CHSToken -> Maybe (Either Error CHSToken))
-> Either Error CHSToken -> Maybe (Either Error CHSToken)
forall a b. (a -> b) -> a -> b
$ CHSToken -> Either Error CHSToken
forall a b. b -> Either a b
Right (Position -> CHSToken
CHSTokEndHook Position
pos),
Position -> Int -> Position
incPos Position
pos Int
2, CHSLexerState
s, CHSLexer -> Maybe CHSLexer
forall a. a -> Maybe a
Just CHSLexer
chslexer)
cLexer :: CHSLexer
cLexer :: CHSLexer
cLexer = CHSLexer
forall s. Lexer s CHSToken
inlineC
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< CHSLexer
ctrl
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< String -> CHSRegexp
forall s t. String -> Regexp s t
string String
"\n#endc"
CHSRegexp -> Meta CHSLexerState CHSToken -> CHSLexer
forall s t. Regexp s t -> Meta s t -> Lexer s t
`lexmeta`
\String
_ Position
pos CHSLexerState
s -> (Either Error CHSToken -> Maybe (Either Error CHSToken)
forall a. a -> Maybe a
Just (Either Error CHSToken -> Maybe (Either Error CHSToken))
-> Either Error CHSToken -> Maybe (Either Error CHSToken)
forall a b. (a -> b) -> a -> b
$ CHSToken -> Either Error CHSToken
forall a b. b -> Either a b
Right (Position -> Char -> CHSToken
CHSTokCtrl Position
pos Char
'\n'), Position -> Position
retPos Position
pos, CHSLexerState
s,
CHSLexer -> Maybe CHSLexer
forall a. a -> Maybe a
Just CHSLexer
chslexer)
where
inlineC :: Lexer s CHSToken
inlineC = String -> Regexp s CHSToken
forall s t. String -> Regexp s t
alt String
inlineSet Regexp s CHSToken -> Action CHSToken -> Lexer s CHSToken
forall s t. Regexp s t -> Action t -> Lexer s t
`lexaction` Action CHSToken
copyVerbatimC
copyVerbatimC :: CHSAction
copyVerbatimC :: Action CHSToken
copyVerbatimC String
cs Position
pos = CHSToken -> Maybe CHSToken
forall a. a -> Maybe a
Just (CHSToken -> Maybe CHSToken) -> CHSToken -> Maybe CHSToken
forall a b. (a -> b) -> a -> b
$ Position -> String -> CHSToken
CHSTokC Position
pos String
cs
whitespace :: CHSLexer
whitespace :: CHSLexer
whitespace = (Char -> CHSRegexp
forall s t. Char -> Regexp s t
char Char
' ' CHSRegexp -> Action CHSToken -> CHSLexer
forall s t. Regexp s t -> Action t -> Lexer s t
`lexaction` \String
_ Position
_ -> Maybe CHSToken
forall a. Maybe a
Nothing)
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< CHSLexer
forall s t. Lexer s t
ctrlLexer
identOrKW :: CHSLexer
identOrKW :: CHSLexer
identOrKW =
(CHSRegexp
forall s t. Regexp s t
letter CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
+> (CHSRegexp
forall s t. Regexp s t
letter CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
>|< CHSRegexp
forall s t. Regexp s t
digit CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
>|< Char -> CHSRegexp
forall s t. Char -> Regexp s t
char Char
'\'')CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
`star` CHSRegexp
forall s t. Regexp s t
epsilon
CHSRegexp -> (String -> Position -> Name -> CHSToken) -> CHSLexer
`lexactionName` \String
cs Position
pos Name
name -> (Position -> String -> Name -> CHSToken
idkwtok (Position -> String -> Name -> CHSToken)
-> Position -> String -> Name -> CHSToken
forall a b. (a -> b) -> a -> b
$!Position
pos) String
cs Name
name)
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||<
(Char -> CHSRegexp
forall s t. Char -> Regexp s t
char Char
'\'' CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
+> CHSRegexp
forall s t. Regexp s t
letter CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
+> (CHSRegexp
forall s t. Regexp s t
letter CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
>|< CHSRegexp
forall s t. Regexp s t
digit)CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
`star` Char -> CHSRegexp
forall s t. Char -> Regexp s t
char Char
'\''
CHSRegexp -> (String -> Position -> Name -> CHSToken) -> CHSLexer
`lexactionName` \String
cs Position
pos Name
name -> (Position -> String -> Name -> CHSToken
mkid (Position -> String -> Name -> CHSToken)
-> Position -> String -> Name -> CHSToken
forall a b. (a -> b) -> a -> b
$!Position
pos) String
cs Name
name)
where
idkwtok :: Position -> String -> Name -> CHSToken
idkwtok Position
pos String
"as" Name
_ = Position -> CHSToken
CHSTokAs Position
pos
idkwtok Position
pos String
"call" Name
_ = Position -> CHSToken
CHSTokCall Position
pos
idkwtok Position
pos String
"class" Name
_ = Position -> CHSToken
CHSTokClass Position
pos
idkwtok Position
pos String
"context" Name
_ = Position -> CHSToken
CHSTokContext Position
pos
idkwtok Position
pos String
"deriving" Name
_ = Position -> CHSToken
CHSTokDerive Position
pos
idkwtok Position
pos String
"enum" Name
_ = Position -> CHSToken
CHSTokEnum Position
pos
idkwtok Position
pos String
"foreign" Name
_ = Position -> CHSToken
CHSTokForeign Position
pos
idkwtok Position
pos String
"fun" Name
_ = Position -> CHSToken
CHSTokFun Position
pos
idkwtok Position
pos String
"get" Name
_ = Position -> CHSToken
CHSTokGet Position
pos
idkwtok Position
pos String
"import" Name
_ = Position -> CHSToken
CHSTokImport Position
pos
idkwtok Position
pos String
"lib" Name
_ = Position -> CHSToken
CHSTokLib Position
pos
idkwtok Position
pos String
"newtype" Name
_ = Position -> CHSToken
CHSTokNewtype Position
pos
idkwtok Position
pos String
"pointer" Name
_ = Position -> CHSToken
CHSTokPointer Position
pos
idkwtok Position
pos String
"prefix" Name
_ = Position -> CHSToken
CHSTokPrefix Position
pos
idkwtok Position
pos String
"pure" Name
_ = Position -> CHSToken
CHSTokPure Position
pos
idkwtok Position
pos String
"qualified" Name
_ = Position -> CHSToken
CHSTokQualif Position
pos
idkwtok Position
pos String
"set" Name
_ = Position -> CHSToken
CHSTokSet Position
pos
idkwtok Position
pos String
"sizeof" Name
_ = Position -> CHSToken
CHSTokSizeof Position
pos
idkwtok Position
pos String
"stable" Name
_ = Position -> CHSToken
CHSTokStable Position
pos
idkwtok Position
pos String
"type" Name
_ = Position -> CHSToken
CHSTokType Position
pos
idkwtok Position
pos String
"underscoreToCase" Name
_ = Position -> CHSToken
CHSTok_2Case Position
pos
idkwtok Position
pos String
"unsafe" Name
_ = Position -> CHSToken
CHSTokUnsafe Position
pos
idkwtok Position
pos String
"with" Name
_ = Position -> CHSToken
CHSTokWith Position
pos
idkwtok Position
pos String
"lock" Name
_ = Position -> CHSToken
CHSTokLock Position
pos
idkwtok Position
pos String
"nolock" Name
_ = Position -> CHSToken
CHSTokNolock Position
pos
idkwtok Position
pos String
cs Name
name = Position -> String -> Name -> CHSToken
mkid Position
pos String
cs Name
name
mkid :: Position -> String -> Name -> CHSToken
mkid Position
pos String
cs Name
name = Position -> Ident -> CHSToken
CHSTokIdent Position
pos (Position -> String -> Name -> Ident
lexemeToIdent Position
pos String
cs Name
name)
symbol :: CHSLexer
symbol :: CHSLexer
symbol = String -> (Position -> CHSToken) -> CHSLexer
forall t s. String -> (Position -> t) -> Lexer s t
sym String
"->" Position -> CHSToken
CHSTokArrow
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< String -> (Position -> CHSToken) -> CHSLexer
forall t s. String -> (Position -> t) -> Lexer s t
sym String
"=>" Position -> CHSToken
CHSTokDArrow
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< String -> (Position -> CHSToken) -> CHSLexer
forall t s. String -> (Position -> t) -> Lexer s t
sym String
"." Position -> CHSToken
CHSTokDot
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< String -> (Position -> CHSToken) -> CHSLexer
forall t s. String -> (Position -> t) -> Lexer s t
sym String
"," Position -> CHSToken
CHSTokComma
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< String -> (Position -> CHSToken) -> CHSLexer
forall t s. String -> (Position -> t) -> Lexer s t
sym String
"=" Position -> CHSToken
CHSTokEqual
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< String -> (Position -> CHSToken) -> CHSLexer
forall t s. String -> (Position -> t) -> Lexer s t
sym String
"-" Position -> CHSToken
CHSTokMinus
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< String -> (Position -> CHSToken) -> CHSLexer
forall t s. String -> (Position -> t) -> Lexer s t
sym String
"*" Position -> CHSToken
CHSTokStar
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< String -> (Position -> CHSToken) -> CHSLexer
forall t s. String -> (Position -> t) -> Lexer s t
sym String
"&" Position -> CHSToken
CHSTokAmp
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< String -> (Position -> CHSToken) -> CHSLexer
forall t s. String -> (Position -> t) -> Lexer s t
sym String
"^" Position -> CHSToken
CHSTokHat
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< String -> (Position -> CHSToken) -> CHSLexer
forall t s. String -> (Position -> t) -> Lexer s t
sym String
"{" Position -> CHSToken
CHSTokLBrace
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< String -> (Position -> CHSToken) -> CHSLexer
forall t s. String -> (Position -> t) -> Lexer s t
sym String
"}" Position -> CHSToken
CHSTokRBrace
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< String -> (Position -> CHSToken) -> CHSLexer
forall t s. String -> (Position -> t) -> Lexer s t
sym String
"(" Position -> CHSToken
CHSTokLParen
CHSLexer -> CHSRegexp
forall s t. Lexer s t -> Lexer s t -> Lexer s t
>||< String -> (Position -> CHSToken) -> CHSLexer
forall t s. String -> (Position -> t) -> Lexer s t
sym String
")" Position -> CHSToken
CHSTokRParen
where
sym :: String -> (Position -> t) -> Lexer s t
sym String
cs Position -> t
con = String -> Regexp s t
forall s t. String -> Regexp s t
string String
cs Regexp s t -> Action t -> Lexer s t
forall s t. Regexp s t -> Action t -> Lexer s t
`lexaction` \String
_ Position
pos -> t -> Maybe t
forall a. a -> Maybe a
Just (Position -> t
con Position
pos)
strlit :: CHSLexer
strlit :: CHSLexer
strlit = Char -> CHSRegexp
forall s t. Char -> Regexp s t
char Char
'"' CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
+> (CHSRegexp
forall s t. Regexp s t
instr CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
>|< Char -> CHSRegexp
forall s t. Char -> Regexp s t
char Char
'\\')CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
`star` Char -> CHSRegexp
forall s t. Char -> Regexp s t
char Char
'"'
CHSRegexp -> Action CHSToken -> CHSLexer
forall s t. Regexp s t -> Action t -> Lexer s t
`lexaction` \String
cs Position
pos -> CHSToken -> Maybe CHSToken
forall a. a -> Maybe a
Just (Position -> String -> CHSToken
CHSTokString Position
pos (ShowS
forall a. [a] -> [a]
init ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
tail ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
cs))
hsverb :: CHSLexer
hsverb :: CHSLexer
hsverb = Char -> CHSRegexp
forall s t. Char -> Regexp s t
char Char
'`' CHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
+> CHSRegexp
forall s t. Regexp s t
inhsverbCHSRegexp -> CHSRegexp -> CHSRegexp
forall s t. Regexp s t -> Regexp s t -> Regexp s t
`star` Char -> CHSRegexp
forall s t. Char -> Regexp s t
char Char
'\''
CHSRegexp -> Action CHSToken -> CHSLexer
forall s t. Regexp s t -> Action t -> Lexer s t
`lexaction` \String
cs Position
pos -> CHSToken -> Maybe CHSToken
forall a. a -> Maybe a
Just (Position -> String -> CHSToken
CHSTokHSVerb Position
pos (ShowS
forall a. [a] -> [a]
init ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
tail ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
cs))
letter, digit, instr, inchar, inhsverb :: Regexp s t
letter :: Regexp s t
letter = String -> Regexp s t
forall s t. String -> Regexp s t
alt [Char
'a'..Char
'z'] Regexp s t -> Regexp s t -> Regexp s t
forall s t. Regexp s t -> Regexp s t -> Regexp s t
>|< String -> Regexp s t
forall s t. String -> Regexp s t
alt [Char
'A'..Char
'Z'] Regexp s t -> Regexp s t -> Regexp s t
forall s t. Regexp s t -> Regexp s t -> Regexp s t
>|< Char -> Regexp s t
forall s t. Char -> Regexp s t
char Char
'_'
digit :: Regexp s t
digit = String -> Regexp s t
forall s t. String -> Regexp s t
alt [Char
'0'..Char
'9']
instr :: Regexp s t
instr = String -> Regexp s t
forall s t. String -> Regexp s t
alt ([Char
' '..Char
'\127'] String -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ String
"\"\\")
inchar :: Regexp s t
inchar = String -> Regexp s t
forall s t. String -> Regexp s t
alt ([Char
' '..Char
'\127'] String -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ String
"\'")
inhsverb :: Regexp s t
inhsverb = String -> Regexp s t
forall s t. String -> Regexp s t
alt ([Char
' '..Char
'\127'] String -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ String
"\'")
anySet, inlineSet, specialSet, commentSpecialSet, ctrlSet :: [Char]
anySet :: String
anySet = [Char
'\0'..Char
'\255']
inlineSet :: String
inlineSet = String
anySet String -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ String
ctrlSet
specialSet :: String
specialSet = [Char
'{', Char
'-', Char
'"', Char
'\'']
= [Char
'{', Char
'-']
ctrlSet :: String
ctrlSet = [Char
'\n', Char
'\f', Char
'\r', Char
'\t', Char
'\v']
lexCHS :: String -> Position -> CST s [CHSToken]
lexCHS :: String -> Position -> CST s [CHSToken]
lexCHS String
cs Position
pos =
do
CHSLexerState
state <- CST s CHSLexerState
forall s. CST s CHSLexerState
initialState
let ([CHSToken]
ts, LexerState CHSLexerState
lstate, [Error]
errs) = CHSLexer
-> LexerState CHSLexerState
-> ([CHSToken], LexerState CHSLexerState, [Error])
forall s t.
Lexer s t -> LexerState s -> ([t], LexerState s, [Error])
execLexer CHSLexer
chslexer (String
cs, Position
pos, CHSLexerState
state)
(String
_, Position
pos', CHSLexerState
state') = LexerState CHSLexerState
lstate
(Error -> PreCST SwitchBoard s ())
-> [Error] -> PreCST SwitchBoard s [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Error -> PreCST SwitchBoard s ()
forall e s. Error -> PreCST e s ()
raise [Error]
errs
Position -> CHSLexerState -> PreCST SwitchBoard s ()
forall s. Position -> CHSLexerState -> CST s ()
assertFinalState Position
pos' CHSLexerState
state'
[CHSToken] -> CST s [CHSToken]
forall (m :: * -> *) a. Monad m => a -> m a
return [CHSToken]
ts