module Curry.Syntax.Lexer
(
Token (..), Category (..), Attributes (..)
, lexSource, lexer, fullLexer
) where
import Prelude hiding (fail)
import Data.Char
( chr, ord, isAlpha, isAlphaNum, isDigit, isHexDigit, isOctDigit
, isSpace, isUpper, toLower
)
import Data.List (intercalate)
import qualified Data.Map as Map
(Map, union, lookup, findWithDefault, fromList)
import Curry.Base.LexComb
import Curry.Base.Position
import Curry.Base.Span
data Token = Token Category Attributes
instance Eq Token where
Token c1 _ == Token c2 _ = c1 == c2
instance Ord Token where
Token c1 _ `compare` Token c2 _ = c1 `compare` c2
instance Symbol Token where
isEOF (Token c _) = c == EOF
dist _ (Token VSemicolon _) = (0, 0)
dist _ (Token VRightBrace _) = (0, 0)
dist _ (Token EOF _) = (0, 0)
dist _ (Token DotDot _) = (0, 1)
dist _ (Token DoubleColon _) = (0, 1)
dist _ (Token LeftArrow _) = (0, 1)
dist _ (Token RightArrow _) = (0, 1)
dist _ (Token DoubleArrow _) = (0, 1)
dist _ (Token KW_do _) = (0, 1)
dist _ (Token KW_if _) = (0, 1)
dist _ (Token KW_in _) = (0, 1)
dist _ (Token KW_of _) = (0, 1)
dist _ (Token Id_as _) = (0, 1)
dist _ (Token KW_let _) = (0, 2)
dist _ (Token PragmaEnd _) = (0, 2)
dist _ (Token KW_case _) = (0, 3)
dist _ (Token KW_class _) = (0, 4)
dist _ (Token KW_data _) = (0, 3)
dist _ (Token KW_default _) = (0, 6)
dist _ (Token KW_deriving _) = (0, 7)
dist _ (Token KW_else _) = (0, 3)
dist _ (Token KW_free _) = (0, 3)
dist _ (Token KW_then _) = (0, 3)
dist _ (Token KW_type _) = (0, 3)
dist _ (Token KW_fcase _) = (0, 4)
dist _ (Token KW_infix _) = (0, 4)
dist _ (Token KW_instance _) = (0, 7)
dist _ (Token KW_where _) = (0, 4)
dist _ (Token Id_ccall _) = (0, 4)
dist _ (Token KW_import _) = (0, 5)
dist _ (Token KW_infixl _) = (0, 5)
dist _ (Token KW_infixr _) = (0, 5)
dist _ (Token KW_module _) = (0, 5)
dist _ (Token Id_forall _) = (0, 5)
dist _ (Token Id_hiding _) = (0, 5)
dist _ (Token KW_newtype _) = (0, 6)
dist _ (Token KW_external _) = (0, 7)
dist _ (Token Id_interface _) = (0, 8)
dist _ (Token Id_primitive _) = (0, 8)
dist _ (Token Id_qualified _) = (0, 8)
dist _ (Token PragmaHiding _) = (0, 9)
dist _ (Token PragmaLanguage _) = (0, 11)
dist _ (Token Id a) = distAttr False a
dist _ (Token QId a) = distAttr False a
dist _ (Token Sym a) = distAttr False a
dist _ (Token QSym a) = distAttr False a
dist _ (Token IntTok a) = distAttr False a
dist _ (Token FloatTok a) = distAttr False a
dist _ (Token CharTok a) = distAttr False a
dist c (Token StringTok a) = updColDist c (distAttr False a)
dist _ (Token LineComment a) = distAttr True a
dist c (Token NestedComment a) = updColDist c (distAttr True a)
dist _ (Token PragmaOptions a) = let (ld, cd) = distAttr False a
in (ld, cd + 11)
dist _ _ = (0, 0)
updColDist :: Int -> Distance -> Distance
updColDist c (ld, cd) = (ld, if ld == 0 then cd else cd - c + 1)
distAttr :: Bool -> Attributes -> Distance
distAttr isComment attr = case attr of
NoAttributes -> (0, 0)
CharAttributes _ orig -> (0, length orig + 1)
IntAttributes _ orig -> (0, length orig - 1)
FloatAttributes _ orig -> (0, length orig - 1)
StringAttributes _ orig
| isComment -> (ld, cd)
| '\n' `elem` orig -> (ld, cd + 1)
| otherwise -> (ld, cd + 2)
where ld = length (filter (== '\n') orig)
cd = length (takeWhile (/= '\n') (reverse orig)) - 1
IdentAttributes mid i -> (0, length (intercalate "." (mid ++ [i])) - 1)
OptionsAttributes mt args -> case mt of
Nothing -> (0, distArgs + 1)
Just t -> (0, length t + distArgs + 2)
where distArgs = length args
data Category
= CharTok
| IntTok
| FloatTok
| StringTok
| Id
| QId
| Sym
| QSym
| LeftParen
| RightParen
| Semicolon
| LeftBrace
| RightBrace
| LeftBracket
| RightBracket
| Comma
| Underscore
| Backquote
| VSemicolon
| VRightBrace
| KW_case
| KW_class
| KW_data
| KW_default
| KW_deriving
| KW_do
| KW_else
| KW_external
| KW_fcase
| KW_free
| KW_if
| KW_import
| KW_in
| KW_infix
| KW_infixl
| KW_infixr
| KW_instance
| KW_let
| KW_module
| KW_newtype
| KW_of
| KW_then
| KW_type
| KW_where
| At
| Colon
| DotDot
| DoubleColon
| Equals
| Backslash
| Bar
| LeftArrow
| RightArrow
| Tilde
| DoubleArrow
| Id_as
| Id_ccall
| Id_forall
| Id_hiding
| Id_interface
| Id_primitive
| Id_qualified
| SymDot
| SymMinus
| SymStar
| PragmaLanguage
| PragmaOptions
| PragmaHiding
| PragmaMethod
| PragmaModule
| PragmaEnd
| LineComment
| NestedComment
| EOF
deriving (Eq, Ord)
data Attributes
= NoAttributes
| CharAttributes { cval :: Char , original :: String }
| IntAttributes { ival :: Integer , original :: String }
| FloatAttributes { fval :: Double , original :: String }
| StringAttributes { sval :: String , original :: String }
| IdentAttributes { modulVal :: [String] , sval :: String }
| OptionsAttributes { toolVal :: Maybe String, toolArgs :: String }
instance Show Attributes where
showsPrec _ NoAttributes = showChar '_'
showsPrec _ (CharAttributes cv _) = shows cv
showsPrec _ (IntAttributes iv _) = shows iv
showsPrec _ (FloatAttributes fv _) = shows fv
showsPrec _ (StringAttributes sv _) = shows sv
showsPrec _ (IdentAttributes mid i) = showsEscaped
$ intercalate "." $ mid ++ [i]
showsPrec _ (OptionsAttributes mt s) = showsTool mt
. showChar ' ' . showString s
where showsTool = maybe id (\t -> showChar '_' . showString t)
showsEscaped :: String -> ShowS
showsEscaped s = showChar '`' . showString s . showChar '\''
showsIdent :: Attributes -> ShowS
showsIdent a = showString "identifier " . shows a
showsSpecialIdent :: String -> ShowS
showsSpecialIdent s = showString "identifier " . showsEscaped s
showsOperator :: Attributes -> ShowS
showsOperator a = showString "operator " . shows a
showsSpecialOperator :: String -> ShowS
showsSpecialOperator s = showString "operator " . showsEscaped s
instance Show Token where
showsPrec _ (Token Id a) = showsIdent a
showsPrec _ (Token QId a) = showString "qualified "
. showsIdent a
showsPrec _ (Token Sym a) = showsOperator a
showsPrec _ (Token QSym a) = showString "qualified "
. showsOperator a
showsPrec _ (Token IntTok a) = showString "integer " . shows a
showsPrec _ (Token FloatTok a) = showString "float " . shows a
showsPrec _ (Token CharTok a) = showString "character " . shows a
showsPrec _ (Token StringTok a) = showString "string " . shows a
showsPrec _ (Token LeftParen _) = showsEscaped "("
showsPrec _ (Token RightParen _) = showsEscaped ")"
showsPrec _ (Token Semicolon _) = showsEscaped ";"
showsPrec _ (Token LeftBrace _) = showsEscaped "{"
showsPrec _ (Token RightBrace _) = showsEscaped "}"
showsPrec _ (Token LeftBracket _) = showsEscaped "["
showsPrec _ (Token RightBracket _) = showsEscaped "]"
showsPrec _ (Token Comma _) = showsEscaped ","
showsPrec _ (Token Underscore _) = showsEscaped "_"
showsPrec _ (Token Backquote _) = showsEscaped "`"
showsPrec _ (Token VSemicolon _)
= showsEscaped ";" . showString " (inserted due to layout)"
showsPrec _ (Token VRightBrace _)
= showsEscaped "}" . showString " (inserted due to layout)"
showsPrec _ (Token At _) = showsEscaped "@"
showsPrec _ (Token Colon _) = showsEscaped ":"
showsPrec _ (Token DotDot _) = showsEscaped ".."
showsPrec _ (Token DoubleArrow _) = showsEscaped "=>"
showsPrec _ (Token DoubleColon _) = showsEscaped "::"
showsPrec _ (Token Equals _) = showsEscaped "="
showsPrec _ (Token Backslash _) = showsEscaped "\\"
showsPrec _ (Token Bar _) = showsEscaped "|"
showsPrec _ (Token LeftArrow _) = showsEscaped "<-"
showsPrec _ (Token RightArrow _) = showsEscaped "->"
showsPrec _ (Token Tilde _) = showsEscaped "~"
showsPrec _ (Token SymDot _) = showsSpecialOperator "."
showsPrec _ (Token SymMinus _) = showsSpecialOperator "-"
showsPrec _ (Token SymStar _) = showsEscaped "*"
showsPrec _ (Token KW_case _) = showsEscaped "case"
showsPrec _ (Token KW_class _) = showsEscaped "class"
showsPrec _ (Token KW_data _) = showsEscaped "data"
showsPrec _ (Token KW_default _) = showsEscaped "default"
showsPrec _ (Token KW_deriving _) = showsEscaped "deriving"
showsPrec _ (Token KW_do _) = showsEscaped "do"
showsPrec _ (Token KW_else _) = showsEscaped "else"
showsPrec _ (Token KW_external _) = showsEscaped "external"
showsPrec _ (Token KW_fcase _) = showsEscaped "fcase"
showsPrec _ (Token KW_free _) = showsEscaped "free"
showsPrec _ (Token KW_if _) = showsEscaped "if"
showsPrec _ (Token KW_import _) = showsEscaped "import"
showsPrec _ (Token KW_in _) = showsEscaped "in"
showsPrec _ (Token KW_infix _) = showsEscaped "infix"
showsPrec _ (Token KW_infixl _) = showsEscaped "infixl"
showsPrec _ (Token KW_infixr _) = showsEscaped "infixr"
showsPrec _ (Token KW_instance _) = showsEscaped "instance"
showsPrec _ (Token KW_let _) = showsEscaped "let"
showsPrec _ (Token KW_module _) = showsEscaped "module"
showsPrec _ (Token KW_newtype _) = showsEscaped "newtype"
showsPrec _ (Token KW_of _) = showsEscaped "of"
showsPrec _ (Token KW_then _) = showsEscaped "then"
showsPrec _ (Token KW_type _) = showsEscaped "type"
showsPrec _ (Token KW_where _) = showsEscaped "where"
showsPrec _ (Token Id_as _) = showsSpecialIdent "as"
showsPrec _ (Token Id_ccall _) = showsSpecialIdent "ccall"
showsPrec _ (Token Id_forall _) = showsSpecialIdent "forall"
showsPrec _ (Token Id_hiding _) = showsSpecialIdent "hiding"
showsPrec _ (Token Id_interface _) = showsSpecialIdent "interface"
showsPrec _ (Token Id_primitive _) = showsSpecialIdent "primitive"
showsPrec _ (Token Id_qualified _) = showsSpecialIdent "qualified"
showsPrec _ (Token PragmaLanguage _) = showString "{-# LANGUAGE"
showsPrec _ (Token PragmaOptions a) = showString "{-# OPTIONS"
. shows a
showsPrec _ (Token PragmaHiding _) = showString "{-# HIDING"
showsPrec _ (Token PragmaMethod _) = showString "{-# METHOD"
showsPrec _ (Token PragmaModule _) = showString "{-# MODULE"
showsPrec _ (Token PragmaEnd _) = showString "#-}"
showsPrec _ (Token LineComment a) = shows a
showsPrec _ (Token NestedComment a) = shows a
showsPrec _ (Token EOF _) = showString "<end-of-file>"
<>) showString
showString "string " . PragmaMethoddentifier">cvalname="line-358"> showsPrec _ (Token= showString "string " . +xer.htmlnInfo
moduleName +xer.htmlnInfo
. +xer.htmlnInfo
(
. -- Furthermore, all rules of the original definition must be
PragmaModule . -- Furthermore, all rules of tpan> "{-# MODULE"
show6"> = -- Furthermoreer hs-var">PragmaModule . -- Furthermore, all rules of tpan> &aModule . 2_ (Token -- Furthermoreer 0s-var">PragmaModulease &aModule <Token 2= where
shspan>_ -- Furthermoree/span>
showsOperator :: s shspan>_ 4span clas-comment">-- Furthermoree/span>
isComment ) = shows cv
showString showsOperator :: s shspan>_r.html#OptionsAttributes">OptionsAspan class="hs-special">(shows e2
ppExpr-6989586621679081987">c : show nCurry.FlatCurry.Annotated.Goodies, = e
OptionsAttributes n class="hs-identifier special">)
shows nCurry.FlatCurry.Annotated.Goodies, = Token Cha> <$>-> \Token Comma Token Comma Token _ (yntax.Lexer.html#KWn class="hs-operator hs-var"><$>Token Comma class="hs-identifier">c (Token __ (Token -- Furthermoreer 0s-var">Praal">original :: where
shspan>_Semicolon
Comb >original :: showsEscaped "external"
showsEscaped "external"
<$&"line-351">(Token where
showsPrec _ = showsEscaped "_"
shovowan> shovowan> shovowan> var">Comma Token StringAttributes :: <{ href="Curry.Fln>
| QSym shovowan> "hs-identifier">cas _LeftBrace
| = QSym (.)<,ovowan> -an class="hs-identifier">VSemicolon
-- ::
showsEscaped "if"
showsPrec _ classhowsEscahs-glyps-identifier hs-var">showsEscths-glyps-identifier hs-var">showsEsclass="hs-identifier hs-type">String }
| 1= case _ classhowsEscahs-glyps-identifier hs-var">showsEsn> Nothing -> | OneLineMode | Curry.Base.Pretty | | aQSym a) span> orig<(8>0)SymMonus
< "no copan>">) |