glualint-1.24.6: src/GLua/TokenTypes.hs
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
-- | Contains class instances and functions related to tokens
module GLua.TokenTypes where
import Data.List
import Text.ParserCombinators.UU.BasicInstances
import GLua.AG.Token
import Data.Aeson
import GHC.Generics
instance Show MToken where
show (MToken _ tok) = show tok
-- | Simple EQ instance. TODO: check for position equality
instance Eq MToken where
(MToken _ t1) == (MToken _ t2) = t1 == t2
-- | Simple Ord instance. TODO: check for position Ord
instance Ord MToken where
compare (MToken _ t1) (MToken _ t2) = compare t1 t2
deriving instance Generic MToken
instance ToJSON MToken where
instance FromJSON MToken where
instance Eq LineColPos where
(LineColPos l c p) == (LineColPos l' c' p') = l == l' && c == c' && p == p'
instance Ord LineColPos where
compare (LineColPos l c _) (LineColPos l' c' _) =
compare l l' `mappend` compare c c'
instance ToJSON LineColPos where
-- this generates a Value
toJSON (LineColPos line col p) =
object ["line" .= line, "column" .= col, "pos" .= p]
#if MIN_VERSION_aeson(0,10,0)
-- this encodes directly to a bytestring Builder
toEncoding (LineColPos line col p) =
pairs ("line" .= line <> "column" .= col <> "pos" .= p)
#endif
instance FromJSON LineColPos where
parseJSON = withObject "LineColPos" $ \v -> LineColPos
<$> v .: "line"
<*> v .: "column"
<*> v .: "pos"
instance Eq Region where
Region s e == Region s' e' = s == s' && e == e'
instance Ord Region where
compare (Region s e) (Region s' e') =
compare s s' `mappend` compare e e'
instance ToJSON Region where
instance FromJSON Region where
instance ToJSON Token where
instance FromJSON Token where
-- | Metatoken algebra
type MTokenAlgebra mtok = Region -> Token -> mtok
mpos :: MToken -> Region
mpos (MToken p _) = p
mtok :: MToken -> Token
mtok (MToken _ t) = t
emptyRg :: Region
emptyRg = Region (LineColPos 0 0 0) (LineColPos 0 0 0)
rgOr :: Region -> Region -> Region
rgOr l r
| l == emptyRg = r
| otherwise = l
----------------------------------------
-- Correcting token positions
----------------------------------------
customAdvanceChr :: LineColPos -> Char -> LineColPos
customAdvanceChr (LineColPos line _ abs') '\n' = LineColPos (line + 1) 0 (abs' + 1)
customAdvanceChr (LineColPos line pos' abs') _ = LineColPos line (pos' + 1) (abs' + 1)
customAdvanceStr :: LineColPos -> String -> LineColPos
customAdvanceStr = foldl' customAdvanceChr
customAdvanceToken :: LineColPos -> Token -> LineColPos
customAdvanceToken (LineColPos line pos' abs') t = let len = tokenSize t in LineColPos line (pos' + len) (abs' + len)
-- | Whether the first region ends strictly before the second region starts
before :: Region -> Region -> Bool
before (Region _ (LineColPos _ _ p)) (Region (LineColPos _ _ p') _ ) = p < p'
-- | Whether the first region ends before or on the same line as the second region
beforeOrOnLine :: Region -> Region -> Bool
beforeOrOnLine (Region _ (LineColPos l _ _)) (Region (LineColPos l' _ _) _) = l <= l'
-- | Whether the first region ends before the second region ends
beforeEnd :: Region -> Region -> Bool
beforeEnd (Region _ (LineColPos _ _ p)) (Region _ (LineColPos _ _ p')) = p < p'
-- | Whether the first region ends before or on the same line as the END of the second region
beforeEndLine :: Region -> Region -> Bool
beforeEndLine (Region _ (LineColPos l _ _)) (Region _ (LineColPos l' _ _)) = l <= l'
rgStart :: Region -> LineColPos
rgStart (Region s _) = s
rgEnd :: Region -> LineColPos
rgEnd (Region _ e) = e
-- | Returns a region that starts at the start of the first region
-- and ends BEFORE the start of the second region
upto :: Region -> Region -> Region
upto lr rr = case (rgEnd lr, rgStart rr) of
(_, LineColPos 0 0 0) -> lr
(LineColPos l c _, LineColPos l' c' _)
| l' > l || (l' == l && c' > c) -> lr
| otherwise -> Region (rgStart lr) (rgStart rr)
-- | Fold over metatoken
foldMToken :: MTokenAlgebra t -> MToken -> t
foldMToken alg (MToken p t) = alg p t
-- | mFold: Apply a TokenAlgebra to an MToken
mFold :: TokenAlgebra a -> MToken -> a
mFold alg = foldMToken f
where
f _ = foldToken alg
-- | Huge token algebra
type TokenAlgebra token = (
( -- Comments and whitespace
String -> token,
String -> token, -- DashComment
Int -> String -> token, -- DashBlockComment
String -> token, -- SlashComment
String -> token, -- SlashBlockComment
token -- Semicolon
),
( -- Constants
String -> token, -- TNumber
String -> token, -- DQString
String -> token, -- SQString
String -> token, -- MLString
token, -- TTrue
token, -- TFalse
token, -- Nil
token -- VarArg
), -- operators
(
token, -- Plus
token, -- Minus
token, -- Multiply
token, -- Divide
token, -- Modulus
token, -- Power
token, -- TEq
token, -- TNEq
token, -- TCNEq
token, -- TLEQ
token, -- TGEQ
token, -- TLT
token, -- TGT
token, -- Equals
token, -- Concatenate
token, -- Colon
token, -- Dot
token, -- Comma
token, -- Hash
token, -- Not
token, -- CNot
token, -- And
token, -- CAnd
token, -- Or
token -- COr
),
( -- Keywords
token, -- Function
token, -- Local
token, -- If
token, -- Then
token, -- Elseif
token, -- Else
token, -- For
token, -- In
token, -- Do
token, -- While
token, -- Until
token, -- Repeat
token, -- Continue
token, -- Break
token, -- Return
token -- End
),
( -- Brackets
token, -- LRound
token, -- RRound
token, -- LCurly
token, -- RCurly
token, -- LSquare
token -- RSquare
),
( -- Other
String -> token, -- Label
String -> token -- Identifier
)
)
-- | Fold over token definition
foldToken :: TokenAlgebra t -> Token -> t
foldToken ((tWhitespace, tDashComment, tDashBlockComment, tSlashComment, tSlashBlockComment, tSemicolon), (tTNumber, tDQString, tSQString, tMLString, tTTrue, tTFalse, tNil, tVarArg), (tPlus, tMinus, tMultiply, tDivide, tModulus, tPower, tTEq, tTNEq, tTCNEq, tTLEQ, tTGEQ, tTLT, tTGT, tEquals, tConcatenate, tColon, tDot, tComma, tHash, tNot, tCNot, tAnd, tCAnd, tOr, tCOr), (tFunction, tLocal, tIf, tThen, tElseif, tElse, tFor, tIn, tDo, tWhile, tUntil, tRepeat, tContinue, tBreak, tReturn, tEnd), (tLRound, tRRound, tLCurly, tRCurly, tLSquare, tRSquare), (tLabel, tIdentifier)) = fold
where
fold (Whitespace str) = tWhitespace str
fold (DashComment str) = tDashComment str
fold (DashBlockComment depth str) = tDashBlockComment depth str
fold (SlashComment str) = tSlashComment str
fold (SlashBlockComment str) = tSlashBlockComment str
fold (TNumber str) = tTNumber str
fold (Label str) = tLabel str
fold (Identifier str) = tIdentifier str
fold (DQString str) = tDQString str
fold (SQString str) = tSQString str
fold (MLString str) = tMLString str
fold And = tAnd
fold CAnd = tCAnd
fold Break = tBreak
fold Do = tDo
fold Else = tElse
fold Elseif = tElseif
fold End = tEnd
fold TFalse = tTFalse
fold For = tFor
fold Function = tFunction
fold If = tIf
fold In = tIn
fold Local = tLocal
fold Nil = tNil
fold Not = tNot
fold CNot = tCNot
fold Or = tOr
fold COr = tCOr
fold Repeat = tRepeat
fold Continue = tContinue
fold Return = tReturn
fold Then = tThen
fold TTrue = tTTrue
fold Until = tUntil
fold While = tWhile
fold Plus = tPlus
fold Minus = tMinus
fold Multiply = tMultiply
fold Divide = tDivide
fold Modulus = tModulus
fold Power = tPower
fold Hash = tHash
fold TEq = tTEq
fold TNEq = tTNEq
fold TCNEq = tTCNEq
fold TLEQ = tTLEQ
fold TGEQ = tTGEQ
fold TLT = tTLT
fold TGT = tTGT
fold Equals = tEquals
fold LRound = tLRound
fold RRound = tRRound
fold LCurly = tLCurly
fold RCurly = tRCurly
fold LSquare = tLSquare
fold RSquare = tRSquare
fold Semicolon = tSemicolon
fold Colon = tColon
fold Comma = tComma
fold Dot = tDot
fold Concatenate = tConcatenate
fold VarArg = tVarArg
-- | Simple show instance
instance Show Token where
show = foldToken ((
id,
("--" ++), -- DashComment
\d s -> let n = replicate d '=' in "--[" ++ n ++ '[' : s ++ ']' : n ++ "]", -- DashBlockComment
("//" ++), -- SlashComment
\s -> "/*" ++ s ++ "*/", -- SlashBlockComment
";" -- Semicolon
),
(
id, -- TNumber
\s -> "\"" ++ s ++ "\"", -- DQString
\s -> "'" ++ s ++ "'", -- SQString
id, -- MLString
"true", -- TTrue
"false", -- TFalse
"nil", -- Nil
"..." -- VarArg
),
(
"+", -- Plus
"-", -- Minus
"*", -- Multiply
"/", -- Divide
"%", -- Modulus
"^", -- Power
"==", -- TEq
"~=", -- TNEq
"!=", -- TCNEq
"<=", -- TLEQ
">=", -- TGEQ
"<", -- TLT
">", -- TGT
"=", -- Equals
"..", -- Concatenate
":", -- Colon
".", -- Dot
",", -- Comma
"#", -- Hash
"not", -- Not
"!", -- CNot
"and", -- And
"&&", -- CAnd
"or", -- Or
"||" -- COr
),
(
"function", -- Function
"local", -- Local
"if", -- If
"then", -- Then
"elseif", -- Elseif
"else", -- Else
"for", -- For
"in", -- In
"do", -- Do
"while", -- While
"until", -- Until
"repeat", -- Repeat
"continue", -- Continue
"break", -- Break
"return", -- Return
"end" -- End
),
(
"(", -- LRound
")", -- RRound
"{", -- LCurly
"}", -- RCurly
"[", -- LSquare
"]" -- RSquare
),
(
id, -- Label
id -- Identifier
)
)
-- | Whether an mtoken is a comment
isWhitespace :: MToken -> Bool
isWhitespace = mFold ((const True,const False,\_ _ -> False,const False,const False,False),(const False,const False,const False,const False,False,False,False,False),(False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False),(False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False),(False,False,False,False,False,False),(const False,const False))
-- | Whether an mtoken is a comment
isComment :: MToken -> Bool
isComment = mFold ((const False,const True,\_ _ -> True,const True,const True,False),(const False,const False,const False,const False,False,False,False,False),(False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False),(False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,False),(False,False,False,False,False,False),(const False,const False))
-- | Split the tokens by comments and other tokens
splitComments :: [MToken] -> ([MToken], [MToken])
splitComments = partition isComment
tokenLabel :: MToken -> String
tokenLabel = mFold ((const "", const "",\_ _ -> "",const "",const "",""),(const "",const "",const "",const "","","","",""),("","","","","","","","","","","","","","","","","","","","","","","","",""),("","","","","","","","","","","","","","","",""),("","","","","",""),(id, id))
-- | The size of a token in characters
tokenSize :: Token -> Int
tokenSize = foldToken ((
length, -- whitespace
(+2) . length, -- DashComment
\d s -> 6 + length s + 2 * d, -- DashBlockComment
(+2) . length, -- SlashComment
(+4) . length, -- SlashBlockComment
1 -- Semicolon
),
(
length, -- TNumber
(+2) . length, -- DQString
(+2) . length, -- SQString
length, -- MLString
4, -- TTrue
5, -- TFalse
3, -- Nil
3 -- VarArg
),
(
1, -- Plus
1, -- Minus
1, -- Multiply
1, -- Divide
1, -- Modulus
1, -- Power
2, -- TEq
2, -- TNEq
2, -- TCNEq
2, -- TLEQ
2, -- TGEQ
1, -- TLT
1, -- TGT
1, -- Equals
2, -- Concatenate
1, -- Colon
1, -- Dot
1, -- Comma
1, -- Hash
3, -- Not
1, -- CNot
3, -- And
2, -- CAnd
2, -- Or
2 -- COr
),
(
8, -- Function
5, -- Local
2, -- If
4, -- Then
6, -- Elseif
4, -- Else
3, -- For
2, -- In
2, -- Do
5, -- While
5, -- Until
6, -- Repeat
8, -- Continue
5, -- Break
6, -- Return
3 -- End
),
(
1, -- LRound
1, -- RRound
1, -- LCurly
1, -- RCurly
1, -- LSquare
1 -- RSquare
),
(
(+2) . length, -- Label
length -- Identifier
)
)
isSingleLineComment :: Token -> Bool
isSingleLineComment = \case
DashComment _ -> True
SlashComment _ -> True
_ -> False