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 pos :: Position
pos ) = Position
pos
posOf (CHSTokDArrow pos :: Position
pos ) = Position
pos
posOf (CHSTokDot pos :: Position
pos ) = Position
pos
posOf (CHSTokComma pos :: Position
pos ) = Position
pos
posOf (CHSTokEqual pos :: Position
pos ) = Position
pos
posOf (CHSTokMinus pos :: Position
pos ) = Position
pos
posOf (CHSTokStar pos :: Position
pos ) = Position
pos
posOf (CHSTokAmp pos :: Position
pos ) = Position
pos
posOf (CHSTokHat pos :: Position
pos ) = Position
pos
posOf (CHSTokLBrace pos :: Position
pos ) = Position
pos
posOf (CHSTokRBrace pos :: Position
pos ) = Position
pos
posOf (CHSTokLParen pos :: Position
pos ) = Position
pos
posOf (CHSTokRParen pos :: Position
pos ) = Position
pos
posOf (CHSTokEndHook pos :: Position
pos ) = Position
pos
posOf (CHSTokAs pos :: Position
pos ) = Position
pos
posOf (CHSTokCall pos :: Position
pos ) = Position
pos
posOf (CHSTokClass pos :: Position
pos ) = Position
pos
posOf (CHSTokContext pos :: Position
pos ) = Position
pos
posOf (CHSTokDerive pos :: Position
pos ) = Position
pos
posOf (CHSTokEnum pos :: Position
pos ) = Position
pos
posOf (CHSTokForeign pos :: Position
pos ) = Position
pos
posOf (CHSTokFun pos :: Position
pos ) = Position
pos
posOf (CHSTokGet pos :: Position
pos ) = Position
pos
posOf (CHSTokImport pos :: Position
pos ) = Position
pos
posOf (CHSTokLib pos :: Position
pos ) = Position
pos
posOf (CHSTokNewtype pos :: Position
pos ) = Position
pos
posOf (CHSTokPointer pos :: Position
pos ) = Position
pos
posOf (CHSTokPrefix pos :: Position
pos ) = Position
pos
posOf (CHSTokPure pos :: Position
pos ) = Position
pos
posOf (CHSTokQualif pos :: Position
pos ) = Position
pos
posOf (CHSTokSet pos :: Position
pos ) = Position
pos
posOf (CHSTokSizeof pos :: Position
pos ) = Position
pos
posOf (CHSTokStable pos :: Position
pos ) = Position
pos
posOf (CHSTokType pos :: Position
pos ) = Position
pos
posOf (CHSTok_2Case pos :: Position
pos ) = Position
pos
posOf (CHSTokUnsafe pos :: Position
pos ) = Position
pos
posOf (CHSTokWith pos :: Position
pos ) = Position
pos
posOf (CHSTokLock pos :: Position
pos ) = Position
pos
posOf (CHSTokNolock pos :: Position
pos ) = Position
pos
posOf (CHSTokString pos :: Position
pos _) = Position
pos
posOf (CHSTokHSVerb pos :: Position
pos _) = Position
pos
posOf (CHSTokIdent pos :: Position
pos _) = Position
pos
posOf (CHSTokHaskell pos :: Position
pos _) = Position
pos
posOf (CHSTokCPP pos :: Position
pos _) = Position
pos
posOf (CHSTokC pos :: Position
pos _) = Position
pos
posOf (CHSTokCtrl pos :: Position
pos _) = Position
pos
posOf (CHSTokPragma pos :: Position
pos ) = Position
pos
posOf (CHSTokPragEnd pos :: Position
pos ) = Position
pos
instance Eq CHSToken where
(CHSTokArrow _ ) == :: CHSToken -> CHSToken -> Bool
== (CHSTokArrow _ ) = Bool
True
(CHSTokDArrow _ ) == (CHSTokDArrow _ ) = Bool
True
(CHSTokDot _ ) == (CHSTokDot _ ) = Bool
True
(CHSTokComma _ ) == (CHSTokComma _ ) = Bool
True
(CHSTokEqual _ ) == (CHSTokEqual _ ) = Bool
True
(CHSTokMinus _ ) == (CHSTokMinus _ ) = Bool
True
(CHSTokStar _ ) == (CHSTokStar _ ) = Bool
True
(CHSTokAmp _ ) == (CHSTokAmp _ ) = Bool
True
(CHSTokHat _ ) == (CHSTokHat _ ) = Bool
True
(CHSTokLBrace _ ) == (CHSTokLBrace _ ) = Bool
True
(CHSTokRBrace _ ) == (CHSTokRBrace _ ) = Bool
True
(CHSTokLParen _ ) == (CHSTokLParen _ ) = Bool
True
(CHSTokRParen _ ) == (CHSTokRParen _ ) = Bool
True
(CHSTokEndHook _ ) == (CHSTokEndHook _ ) = Bool
True
(CHSTokAs _ ) == (CHSTokAs _ ) = Bool
True
(CHSTokCall _ ) == (CHSTokCall _ ) = Bool
True
(CHSTokClass _ ) == (CHSTokClass _ ) = Bool
True
(CHSTokContext _ ) == (CHSTokContext _ ) = Bool
True
(CHSTokDerive _ ) == (CHSTokDerive _ ) = Bool
True
(CHSTokEnum _ ) == (CHSTokEnum _ ) = Bool
True
(CHSTokForeign _ ) == (CHSTokForeign _ ) = Bool
True
(CHSTokFun _ ) == (CHSTokFun _ ) = Bool
True
(CHSTokGet _ ) == (CHSTokGet _ ) = Bool
True
(CHSTokImport _ ) == (CHSTokImport _ ) = Bool
True
(CHSTokLib _ ) == (CHSTokLib _ ) = Bool
True
(CHSTokNewtype _ ) == (CHSTokNewtype _ ) = Bool
True
(CHSTokPointer _ ) == (CHSTokPointer _ ) = Bool
True
(CHSTokPrefix _ ) == (CHSTokPrefix _ ) = Bool
True
(CHSTokPure _ ) == (CHSTokPure _ ) = Bool
True
(CHSTokQualif _ ) == (CHSTokQualif _ ) = Bool
True
(CHSTokSet _ ) == (CHSTokSet _ ) = Bool
True
(CHSTokSizeof _ ) == (CHSTokSizeof _ ) = Bool
True
(CHSTokStable _ ) == (CHSTokStable _ ) = Bool
True
(CHSTokType _ ) == (CHSTokType _ ) = Bool
True
(CHSTok_2Case _ ) == (CHSTok_2Case _ ) = Bool
True
(CHSTokUnsafe _ ) == (CHSTokUnsafe _ ) = Bool
True
(CHSTokWith _ ) == (CHSTokWith _ ) = Bool
True
(CHSTokLock _ ) == (CHSTokLock _ ) = Bool
True
(CHSTokNolock _ ) == (CHSTokNolock _ ) = Bool
True
(CHSTokString _ _) == (CHSTokString _ _) = Bool
True
(CHSTokHSVerb _ _) == (CHSTokHSVerb _ _) = Bool
True
(CHSTokIdent _ _) == (CHSTokIdent _ _) = Bool
True
(CHSTokHaskell _ _) == (CHSTokHaskell _ _) = Bool
True
(CHSTokCPP _ _) == (CHSTokCPP _ _) = Bool
True
(CHSTokC _ _) == (CHSTokC _ _) = Bool
True
(CHSTokCtrl _ _) == (CHSTokCtrl _ _) = Bool
True
(CHSTokPragma _ ) == (CHSTokPragma _ ) = Bool
True
(CHSTokPragEnd _ ) == (CHSTokPragEnd _ ) = Bool
True
_ == _ = Bool
False
instance Show CHSToken where
showsPrec :: Int -> CHSToken -> ShowS
showsPrec _ (CHSTokArrow _ ) = String -> ShowS
showString "->"
showsPrec _ (CHSTokDArrow _ ) = String -> ShowS
showString "=>"
showsPrec _ (CHSTokDot _ ) = String -> ShowS
showString "."
showsPrec _ (CHSTokComma _ ) = String -> ShowS
showString ","
showsPrec _ (CHSTokEqual _ ) = String -> ShowS
showString "="
showsPrec _ (CHSTokMinus _ ) = String -> ShowS
showString "-"
showsPrec _ (CHSTokStar _ ) = String -> ShowS
showString "*"
showsPrec _ (CHSTokAmp _ ) = String -> ShowS
showString "&"
showsPrec _ (CHSTokHat _ ) = String -> ShowS
showString "^"
showsPrec _ (CHSTokLBrace _ ) = String -> ShowS
showString "{"
showsPrec _ (CHSTokRBrace _ ) = String -> ShowS
showString "}"
showsPrec _ (CHSTokLParen _ ) = String -> ShowS
showString "("
showsPrec _ (CHSTokRParen _ ) = String -> ShowS
showString ")"
showsPrec _ (CHSTokEndHook _ ) = String -> ShowS
showString "#}"
showsPrec _ (CHSTokAs _ ) = String -> ShowS
showString "as"
showsPrec _ (CHSTokCall _ ) = String -> ShowS
showString "call"
showsPrec _ (CHSTokClass _ ) = String -> ShowS
showString "class"
showsPrec _ (CHSTokContext _ ) = String -> ShowS
showString "context"
showsPrec _ (CHSTokDerive _ ) = String -> ShowS
showString "deriving"
showsPrec _ (CHSTokEnum _ ) = String -> ShowS
showString "enum"
showsPrec _ (CHSTokForeign _ ) = String -> ShowS
showString "foreign"
showsPrec _ (CHSTokFun _ ) = String -> ShowS
showString "fun"
showsPrec _ (CHSTokGet _ ) = String -> ShowS
showString "get"
showsPrec _ (CHSTokImport _ ) = String -> ShowS
showString "import"
showsPrec _ (CHSTokLib _ ) = String -> ShowS
showString "lib"
showsPrec _ (CHSTokNewtype _ ) = String -> ShowS
showString "newtype"
showsPrec _ (CHSTokPointer _ ) = String -> ShowS
showString "pointer"
showsPrec _ (CHSTokPrefix _ ) = String -> ShowS
showString "prefix"
showsPrec _ (CHSTokPure _ ) = String -> ShowS
showString "pure"
showsPrec _ (CHSTokQualif _ ) = String -> ShowS
showString "qualified"
showsPrec _ (CHSTokSet _ ) = String -> ShowS
showString "set"
showsPrec _ (CHSTokSizeof _ ) = String -> ShowS
showString "sizeof"
showsPrec _ (CHSTokStable _ ) = String -> ShowS
showString "stable"
showsPrec _ (CHSTokType _ ) = String -> ShowS
showString "type"
showsPrec _ (CHSTok_2Case _ ) = String -> ShowS
showString "underscoreToCase"
showsPrec _ (CHSTokUnsafe _ ) = String -> ShowS
showString "unsafe"
showsPrec _ (CHSTokWith _ ) = String -> ShowS
showString "with"
showsPrec _ (CHSTokLock _ ) = String -> ShowS
showString "lock"
showsPrec _ (CHSTokNolock _ ) = String -> ShowS
showString "nolock"
showsPrec _ (CHSTokString _ s :: String
s) = String -> ShowS
showString ("\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\"")
showsPrec _ (CHSTokHSVerb _ s :: String
s) = String -> ShowS
showString ("`" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ "'")
showsPrec _ (CHSTokIdent _ i :: 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 _ (CHSTokHaskell _ s :: String
s) = String -> ShowS
showString String
s
showsPrec _ (CHSTokCPP _ s :: String
s) = String -> ShowS
showString String
s
showsPrec _ (CHSTokC _ s :: String
s) = String -> ShowS
showString String
s
showsPrec _ (CHSTokCtrl _ c :: Char
c) = Char -> ShowS
showChar Char
c
showsPrec _ (CHSTokPragma _ ) = String -> ShowS
showString "{-# LANGUAGE"
showsPrec _ (CHSTokPragEnd _ ) = String -> ShowS
showString "#-}"
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 = 0,
inHook :: Bool
inHook = Bool
False,
namesup :: [Name]
namesup = [Name]
namesup
}
assertFinalState :: Position -> CHSLexerState -> CST s ()
assertFinalState :: Position -> CHSLexerState -> CST s ()
assertFinalState pos :: 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
> 0 = Position -> [String] -> CST s ()
forall e s. Position -> [String] -> PreCST e s ()
raiseError Position
pos ["Unexpected end of file!",
"Unclosed nested comment."]
| Bool
inHook = Position -> [String] -> CST s ()
forall e s. Position -> [String] -> PreCST e s ()
raiseError Position
pos ["Unexpected end of file!",
"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
re :: CHSRegexp
re lexactionName :: CHSRegexp -> (String -> Position -> Name -> CHSToken) -> CHSLexer
`lexactionName` action :: 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' str :: String
str pos :: Position
pos state :: CHSLexerState
state = let name :: Name
name:ns :: [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 "{-# LANGUAGE" CHSRegexp -> Meta CHSLexerState CHSToken -> CHSLexer
forall s t. Regexp s t -> Meta s t -> Lexer s t
`lexmeta` \_ pos :: Position
pos s :: 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 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 "#-}" CHSRegexp -> Meta CHSLexerState CHSToken -> CHSLexer
forall s t. Regexp s t -> Meta s t -> Lexer s t
`lexmeta` \_ pos :: Position
pos s :: 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 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 '"' 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 '"'
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 "'\"'"
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 "--" 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 '"'
CHSRegexp -> ActionErr CHSToken -> CHSLexer
forall s t. Regexp s t -> ActionErr t -> Lexer s t
`lexactionErr`
\_ pos :: 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
["Lexical error!",
"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]
\\ ['"'])
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]
\\ ['\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 '\\' 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 "\\\"" 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 '\\' 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 -> 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 '\\'
copyVerbatim :: CHSAction
copyVerbatim :: Action CHSToken
copyVerbatim cs :: String
cs pos :: 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 "{-"
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 "-}"
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 cs :: String
cs pos :: Position
pos s :: 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 2,
CHSLexerState
s {nestLvl :: Int
nestLvl = CHSLexerState -> Int
nestLvl CHSLexerState
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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 cs :: String
cs pos :: Position
pos s :: CHSLexerState
s =
case CHSLexerState -> Int
nestLvl CHSLexerState
s of
0 -> (Position -> Maybe (Either Error CHSToken)
forall b. Position -> Maybe (Either Error b)
commentCloseErr Position
pos,
Position -> Int -> Position
incPos Position
pos 2,
CHSLexerState
s,
Maybe CHSLexer
forall a. Maybe a
Nothing)
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 2,
CHSLexerState
s {nestLvl :: Int
nestLvl = CHSLexerState -> Int
nestLvl CHSLexerState
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1},
CHSLexer -> Maybe CHSLexer
forall a. a -> Maybe a
Just CHSLexer
chslexer)
_ -> (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 2,
CHSLexerState
s {nestLvl :: Int
nestLvl = CHSLexerState -> Int
nestLvl CHSLexerState
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1},
Maybe CHSLexer
forall a. Maybe a
Nothing)
copyVerbatim' :: String -> Position -> Maybe (Either a CHSToken)
copyVerbatim' cs :: String
cs pos :: 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 pos :: 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
["Lexical error!",
"`-}' 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 '\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 '\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 '\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 '\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 '\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 [c :: Char
c] pos :: 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 [c :: Char
c] pos :: 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 1)
tab :: String
-> Position
-> c
-> (Maybe (Either a CHSToken), Position, c, Maybe a)
tab [c :: Char
c] pos :: 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 pos :: Position
pos c :: Char
c pos' :: b
pos' s :: 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 "{#"
CHSRegexp -> Meta CHSLexerState CHSToken -> CHSLexer
forall s t. Regexp s t -> Meta s t -> Lexer s t
`lexmeta` \_ pos :: Position
pos s :: CHSLexerState
s -> (Maybe (Either Error CHSToken)
forall a. Maybe a
Nothing, Position -> Int -> Position
incPos Position
pos 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 "\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 ('\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`
\(_:_:dir :: String
dir) pos :: Position
pos s :: CHSLexerState
s ->
case String
dir of
['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)
'c':sp :: Char
sp:_ | Char
sp Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` " \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)
' ':line :: String
line@(n :: Char
n:_) | 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)
_ ->
(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 str :: String
str (Position fname :: String
fname _ _) =
(String -> Int -> Int -> Position
Position String
fname' Int
row' 0)
where
str' :: String
str' = ShowS
dropWhite String
str
(rowStr :: String
rowStr, str'' :: 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
/= '"') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
drop 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
/= '"' = 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 (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\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 "--" 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 '\n'
CHSRegexp -> Meta CHSLexerState CHSToken -> CHSLexer
forall s t. Regexp s t -> Meta s t -> Lexer s t
`lexmeta` \_ pos :: Position
pos s :: 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]
\\ ['\n'])
endOfHook :: CHSLexer
endOfHook = String -> CHSRegexp
forall s t. String -> Regexp s t
string "#}"
CHSRegexp -> Meta CHSLexerState CHSToken -> CHSLexer
forall s t. Regexp s t -> Meta s t -> Lexer s t
`lexmeta`
\_ pos :: Position
pos s :: 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 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 "\n#endc"
CHSRegexp -> Meta CHSLexerState CHSToken -> CHSLexer
forall s t. Regexp s t -> Meta s t -> Lexer s t
`lexmeta`
\_ pos :: Position
pos s :: 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 '\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 cs :: String
cs pos :: 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 ' ' CHSRegexp -> Action CHSToken -> CHSLexer
forall s t. Regexp s t -> Action t -> Lexer s t
`lexaction` \_ _ -> 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 '\'')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` \cs :: String
cs pos :: Position
pos name :: 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 '\'' 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 '\''
CHSRegexp -> (String -> Position -> Name -> CHSToken) -> CHSLexer
`lexactionName` \cs :: String
cs pos :: Position
pos name :: 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 pos :: Position
pos "as" _ = Position -> CHSToken
CHSTokAs Position
pos
idkwtok pos :: Position
pos "call" _ = Position -> CHSToken
CHSTokCall Position
pos
idkwtok pos :: Position
pos "class" _ = Position -> CHSToken
CHSTokClass Position
pos
idkwtok pos :: Position
pos "context" _ = Position -> CHSToken
CHSTokContext Position
pos
idkwtok pos :: Position
pos "deriving" _ = Position -> CHSToken
CHSTokDerive Position
pos
idkwtok pos :: Position
pos "enum" _ = Position -> CHSToken
CHSTokEnum Position
pos
idkwtok pos :: Position
pos "foreign" _ = Position -> CHSToken
CHSTokForeign Position
pos
idkwtok pos :: Position
pos "fun" _ = Position -> CHSToken
CHSTokFun Position
pos
idkwtok pos :: Position
pos "get" _ = Position -> CHSToken
CHSTokGet Position
pos
idkwtok pos :: Position
pos "import" _ = Position -> CHSToken
CHSTokImport Position
pos
idkwtok pos :: Position
pos "lib" _ = Position -> CHSToken
CHSTokLib Position
pos
idkwtok pos :: Position
pos "newtype" _ = Position -> CHSToken
CHSTokNewtype Position
pos
idkwtok pos :: Position
pos "pointer" _ = Position -> CHSToken
CHSTokPointer Position
pos
idkwtok pos :: Position
pos "prefix" _ = Position -> CHSToken
CHSTokPrefix Position
pos
idkwtok pos :: Position
pos "pure" _ = Position -> CHSToken
CHSTokPure Position
pos
idkwtok pos :: Position
pos "qualified" _ = Position -> CHSToken
CHSTokQualif Position
pos
idkwtok pos :: Position
pos "set" _ = Position -> CHSToken
CHSTokSet Position
pos
idkwtok pos :: Position
pos "sizeof" _ = Position -> CHSToken
CHSTokSizeof Position
pos
idkwtok pos :: Position
pos "stable" _ = Position -> CHSToken
CHSTokStable Position
pos
idkwtok pos :: Position
pos "type" _ = Position -> CHSToken
CHSTokType Position
pos
idkwtok pos :: Position
pos "underscoreToCase" _ = Position -> CHSToken
CHSTok_2Case Position
pos
idkwtok pos :: Position
pos "unsafe" _ = Position -> CHSToken
CHSTokUnsafe Position
pos
idkwtok pos :: Position
pos "with" _ = Position -> CHSToken
CHSTokWith Position
pos
idkwtok pos :: Position
pos "lock" _ = Position -> CHSToken
CHSTokLock Position
pos
idkwtok pos :: Position
pos "nolock" _ = Position -> CHSToken
CHSTokNolock Position
pos
idkwtok pos :: Position
pos cs :: String
cs name :: Name
name = Position -> String -> Name -> CHSToken
mkid Position
pos String
cs Name
name
mkid :: Position -> String -> Name -> CHSToken
mkid pos :: Position
pos cs :: String
cs name :: 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 "->" 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 "=>" 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 "." 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 "," 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 "=" 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 "-" 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 "*" 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 "&" 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 "^" 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 "{" 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 "}" 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 "(" 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 ")" Position -> CHSToken
CHSTokRParen
where
sym :: String -> (Position -> t) -> Lexer s t
sym cs :: String
cs con :: 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` \_ pos :: 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 '"' 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 '\\')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 '"'
CHSRegexp -> Action CHSToken -> CHSLexer
forall s t. Regexp s t -> Action t -> Lexer s t
`lexaction` \cs :: String
cs pos :: 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 '`' 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 '\''
CHSRegexp -> Action CHSToken -> CHSLexer
forall s t. Regexp s t -> Action t -> Lexer s t
`lexaction` \cs :: String
cs pos :: 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 ['a'..'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 ['A'..'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 '_'
digit :: Regexp s t
digit = String -> Regexp s t
forall s t. String -> Regexp s t
alt ['0'..'9']
instr :: Regexp s t
instr = String -> Regexp s t
forall s t. String -> Regexp s t
alt ([' '..'\127'] String -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ "\"\\")
inchar :: Regexp s t
inchar = String -> Regexp s t
forall s t. String -> Regexp s t
alt ([' '..'\127'] String -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ "\'")
inhsverb :: Regexp s t
inhsverb = String -> Regexp s t
forall s t. String -> Regexp s t
alt ([' '..'\127'] String -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ "\'")
anySet, inlineSet, specialSet, commentSpecialSet, ctrlSet :: [Char]
anySet :: String
anySet = ['\0'..'\255']
inlineSet :: String
inlineSet = String
anySet String -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ String
ctrlSet
specialSet :: String
specialSet = ['{', '-', '"', '\'']
= ['{', '-']
ctrlSet :: String
ctrlSet = ['\n', '\f', '\r', '\t', '\v']
lexCHS :: String -> Position -> CST s [CHSToken]
lexCHS :: String -> Position -> CST s [CHSToken]
lexCHS cs :: String
cs pos :: Position
pos =
do
CHSLexerState
state <- CST s CHSLexerState
forall s. CST s CHSLexerState
initialState
let (ts :: [CHSToken]
ts, lstate :: LexerState CHSLexerState
lstate, errs :: [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)
(_, pos' :: Position
pos', state' :: 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