ampersand-3.1.0: src/Database/Design/Ampersand/Input/ADL1/Lexer.hs
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
module Database.Design.Ampersand.Input.ADL1.Lexer
( keywords
, operators
, symbols
, lexer
-- LexerMessage
, LexerError(..)
, LexerErrorInfo(..)
, LexerWarning(..)
, LexerWarningInfo(..)
, keepOneTabWarning
, showLexerErrorInfo
, showLexerWarningInfo
-- LexerToken
, Token(..)
, Lexeme(..)
, lexemeText
, initPos
, FilePos(..)
) where
import Database.Design.Ampersand.Input.ADL1.FilePos(updatePos)
import Database.Design.Ampersand.Input.ADL1.LexerToken
import Database.Design.Ampersand.Input.ADL1.LexerMonad
import Database.Design.Ampersand.Input.ADL1.LexerMessage
import Data.Char hiding(isSymbol)
import Data.Set (member, fromList)
import Database.Design.Ampersand.Basics (fatalMsg)
import Database.Design.Ampersand.Misc
import Data.Time.Calendar
import Data.Time.Clock
import Numeric
fatal :: Int -> String -> a
fatal = fatalMsg "Lexer"
-- | Retrieves a list of keywords accepted by the ampersand language
keywords :: [String] -- ^ The keywords
keywords = [ "INCLUDE"
, "CONTEXT", "ENDCONTEXT", "EXTENDS", "THEMES"
, "META"
, "PATTERN", "ENDPATTERN"
, "PROCESS", "ENDPROCESS"
, "INTERFACE", "CLASS", "FOR", "BOX", "ROWS", "TABS", "COLS", "INITIAL", "SQLPLUG", "PHPPLUG"
, "REPRESENT", "TYPE", "LINKTO"
, "POPULATION", "CONTAINS"
, "UNI", "INJ", "SUR", "TOT", "SYM", "ASY", "TRN", "RFX", "IRF", "AUT", "PROP", "ALWAYS"
, "RULE", "MESSAGE", "VIOLATION", "SRC", "TGT", "TEST"
, "RELATION", "MEANING", "CONCEPT", "IDENT"
, "VIEW", "ENDVIEW", "DEFAULT", "TXT", "PRIMHTML", "TEMPLATE"
, "IMPORT", "SPEC", "ISA", "IS", "I", "V"
, "CLASSIFY"
, "PRAGMA", "PURPOSE", "IN", "REF", "ENGLISH", "DUTCH"
, "REST", "HTML", "LATEX", "MARKDOWN"
, "ONE"
, "BYPLUG"
, "ROLE", "SERVICE", "EDITS", "MAINTAINS"
-- Keywords for TType:
, "ALPHANUMERIC", "BIGALPHANUMERIC", "HUGEALPHANUMERIC", "PASSWORD"
, "BINARY", "BIGBINARY", "HUGEBINARY"
, "DATE", "DATETIME", "BOOLEAN", "INTEGER", "FLOAT", "AUTOINCREMENT"
-- Keywords for values of atoms:
, "TRUE", "FALSE" --for booleans
]
-- | Retrieves a list of operators accepted by the ampersand language
operators :: [String] -- ^ The operators
operators = [ "|-", "-", "->", "<-", "=", "~", "+", "*", ";", "!", "#",
"::", ":", "\\/", "/\\", "\\", "/", "<>" , "..", "."]
-- | Retrieves the list of symbols accepted by the ampersand language
symbols :: String -- ^ The list of symbol characters / [Char]
symbols = "()[],{}<>"
--TODO: Options should be one item, not a list
-- | Runs the lexer
lexer :: [Options] -- ^ The command line options
-> FilePath -- ^ The file name, used for error messages
-> String -- ^ The content of the file
-> Either LexerError ([Token], [LexerWarning]) -- ^ Either an error or a list of tokens and warnings
lexer opt file input = case runLexerMonad opt file (mainLexer (initPos file) input) of
Left err -> Left err
Right (ts, ws) -> Right (ts, ws)
-----------------------------------------------------------
-- Help functions
-----------------------------------------------------------
skipLine :: String -> String
skipLine = dropWhile (/= '\n')
takeLine :: String -> String
takeLine = takeWhile (/= '\n')
-----------------------------------------------------------
-- Lexer definition
-----------------------------------------------------------
type Lexer = FilePos -> String -> LexerMonad [Token]
mainLexer :: Lexer
-----------------------------------------------------------
-- Removing unnecessary text artifacts (comment, spaces,...)
-----------------------------------------------------------
mainLexer _ [] = return []
mainLexer p ('-':'-':s) = mainLexer p (skipLine s) --TODO: Test if we should increase line number and reset the column number
mainLexer p (c:s) | isSpace c = let (spc,next) = span isSpace s
in mainLexer (foldl updatePos p (c:spc)) next
mainLexer p ('-':'+':s) = returnToken lx p mainLexer p rest
where lx = LexExpl $ dropWhile isSpace (takeLine s)
rest = skipLine s
mainLexer p ('{':'-':s) = lexNest mainLexer (addPos 2 p) s
mainLexer p ('{':'+':s) = lexExpl mainLexer (addPos 2 p) s
mainLexer p ('"':ss) =
let (s,swidth,rest) = scanString ss
in if null rest || head rest /= '"'
then lexerError (NonTerminatedString s) p
else returnToken (LexString s) p mainLexer (addPos (swidth+2) p) (tail rest)
{- In Ampersand, atoms may be promoted to singleton relations by single-quoting them. For this purpose, we treat
single quotes exactly as the double quote for strings. That substitutes the scanner code for character literals. -}
mainLexer p ('\'':ss)
= let (s,swidth,rest) = scanSingletonInExpression ss
in if null rest || head rest /= '\''
then lexerError UnterminatedAtom p
else returnToken (LexSingleton s) p mainLexer (addPos (swidth+2) p) (tail rest)
-----------------------------------------------------------
-- looking for keywords - operators - special chars
-----------------------------------------------------------
-- Special case for < since it's the beginning of operators but also a symbol when alone
mainLexer p ('<':d:s) = if isOperator ['<',d]
then returnToken (LexOperator ['<',d]) p mainLexer (addPos 2 p) s
else returnToken (LexSymbol '<') p mainLexer (addPos 1 p) (d:s)
mainLexer p cs@(c:s)
| isIdStart c || isUpper c
= let (name', p', s') = scanIdent (addPos 1 p) s
name = c:name'
tokt | iskw name = LexKeyword name
| otherwise = if isIdStart c
then LexVarId name
else LexConId name
in returnToken tokt p mainLexer p' s'
| isOperatorBegin c
= let (name, s') = getOp cs
in returnToken (LexOperator name) p mainLexer (foldl updatePos p name) s'
| isSymbol c = returnToken (LexSymbol c) p mainLexer (addPos 1 p) s
| isDigit c
= case getDateTime cs of
Just (Right (tk,_,width,s')) -> returnToken tk p mainLexer (addPos width p) s'
Just (Left msg) -> lexerError msg p
Nothing
-> case getDate cs of
Just (tk,_,width,s') -> returnToken tk p mainLexer (addPos width p) s'
Nothing -> let (tk,_,width,s') = getNumber cs
in returnToken tk p mainLexer (addPos width p) s'
-- Ignore unexpected characters in the beginning of the file because of the UTF-8 BOM marker.
-- TODO: Find out the right way of handling the BOM marker.
| beginFile p = do { lexerWarning UtfChar p; mainLexer p s }
| otherwise = lexerError (UnexpectedChar c) p
where beginFile (FilePos _ 1 1) = True
beginFile _ = False
-----------------------------------------------------------
-----------------------------------------------------------
-- Supporting functions for MainLexer
-----------------------------------------------------------
-----------------------------------------------------------
-----------------------------------------------------------
-- Check on keywords - operators - special chars
-----------------------------------------------------------
locatein :: Ord a => [a] -> a -> Bool
locatein es e = member e (fromList es)
iskw :: String -> Bool
iskw = locatein keywords
isSymbol :: Char -> Bool
isSymbol = locatein symbols
isOperator :: String -> Bool
isOperator = locatein operators
isOperatorBegin :: Char -> Bool
isOperatorBegin = locatein (map head operators)
isIdStart :: Char -> Bool
isIdStart c = isLower c || c == '_'
isIdChar :: Char -> Bool
isIdChar c = isAlphaNum c || c == '_'
-- Finds the longest prefix of cs occurring in keywordsops
getOp :: String -> (String, String)
getOp cs = findOper operators cs ""
where findOper :: [String] -> String -> String -> (String,String)
findOper [] _ _ = ("", cs)
findOper _ [] op = (op,[])
findOper ops (c:rest) op =
if null found then (op, c:rest)
else findOper found rest (op ++ [c])
where found = [s' | o:s'<-ops, c==o]
-- scan ident receives a file position and the resting contents, returning the scanned identifier, the file location and the resting contents.
scanIdent :: FilePos -> String -> (String, FilePos, String)
scanIdent p s = let (name,rest) = span isIdChar s
in (name,addPos (length name) p,rest)
-----------------------------------------------------------
-- String clean-up functions / comments
-----------------------------------------------------------
lexNest :: Lexer -> Lexer
lexNest c p ('-':'}':s) = c (addPos 2 p) s
lexNest c p ('{':'-':s) = lexNest (lexNest c) (addPos 2 p) s
lexNest c p (x:s) = lexNest c (updatePos p x) s
lexNest _ p [] = lexerError UnterminatedComment p
--TODO: Also accept {+ ... +} as delimiters
lexExpl :: Lexer -> Lexer
lexExpl = lexExpl' ""
where lexExpl' str _ p ('-':'}':s) = returnToken (LexExpl str) p mainLexer (addPos 2 p) s
lexExpl' str c p ('{':'-':s) = lexNest (lexExpl' str c) (addPos 2 p) s
lexExpl' str c p ('-':'-':s) = lexExpl' str c p (dropWhile (/= '\n') s)
lexExpl' str c p (x:s) = lexExpl' (str++[x]) c (updatePos p x) s
lexExpl' _ _ p [] = lexerError UnterminatedPurpose p
-----------------------------------------------------------
-- iso 8601 date / time
-----------------------------------------------------------
-- Returns tuple with the parsed lexeme, the UTCTime, the amount of read characters and the rest of the text
getDateTime :: String -> Maybe (Either LexerErrorInfo (Lexeme, UTCTime, Int, String) )
getDateTime cs =
case getDate cs of
Nothing -> Nothing
Just (_,day,ld,rd) ->
case getTime rd of
Nothing -> case rd of
'T':_ -> Just . Left $ ProblematicISO8601DateTime
_ -> Nothing
Just (timeOfDay, tzoneOffset,lt,rt) ->
let ucttime = addUTCTime tzoneOffset (UTCTime day timeOfDay)
in Just . Right $
( LexDateTime ucttime
, ucttime
, ld + lt
, rt
)
getTime :: String -> Maybe (DiffTime, NominalDiffTime, Int, String)
getTime cs =
case cs of
'T':h1:h2:':':m1:m2:rest
-> if (all isDigit [h1,h2,m1,m2])
then let (_,Left hours,_,_) = getNumber [h1,h2]
(_,Left minutes,_,_) = getNumber [m1,m2]
(seconds,ls,rs) = getSeconds rest
in case getTZD rs of
Nothing -> Nothing
Just (offset,lo,ro)
-> if hours < 24 && minutes < 60 && seconds < 60
then Just (fromRational . toRational $
( fromIntegral hours*60
+fromIntegral minutes
)*60+ seconds
,offset
,1+5+ls+lo
,ro)
else Nothing
else Nothing
_ -> Nothing
getSeconds :: String -> (Float,Int,String)
getSeconds cs =
case cs of
(':':s1:s2:rest) ->
if all isDigit [s1,s2]
then let (fraction,lf,rf) = getFraction (s1:s2:rest)
in (fraction,1+lf,rf)
else (0,0,cs)
_ -> (0,0,cs)
getFraction :: String -> (Float,Int,String)
getFraction cs =
case readFloat cs of
[(a,str)] -> (a, length cs - length str, str) --TODO: Make more efficient.
_ -> (0,0,cs)
getTZD :: String -> Maybe (NominalDiffTime, Int,String)
getTZD cs =
case cs of
'Z':rest -> Just (0,1,rest)
'+':h1:h2:':':m1:m2:rest -> mkOffset [h1,h2] [m1,m2] rest (+)
'-':h1:h2:':':m1:m2:rest -> mkOffset [h1,h2] [m1,m2] rest (-)
_ -> Nothing
where
mkOffset :: String -> String -> String -> (Int -> Int -> Int) -> Maybe (NominalDiffTime, Int,String)
mkOffset hs ms rest op =
let (_,Left hours ,_,_) = getNumber hs
(_,Left minutes,_,_) = getNumber ms
total = hours*60+minutes
in if hours <= 24 && minutes < 60
then Just (fromRational . toRational $ 0 `op` total
,6,rest)
else Nothing
getDate :: String -> Maybe (Lexeme, Day, Int, String)
getDate cs =
case cs of
y1:y2:y3:y4:'-':m1:m2:'-':d1:d2:rest ->
if all isDigit [y1,y2,y3,y4,m1,m2,d1,d2]
then case fromGregorianValid (toInteger year) month day of
Nothing -> Nothing
Just d -> Just (LexDate d, d, 10, rest)
else Nothing
where (_,Left year ,_,_) = getNumber [y1,y2,y3,y4]
(_,Left month,_,_) = getNumber [m1,m2]
(_,Left day ,_,_) = getNumber [d1,d2]
_ -> Nothing
-----------------------------------------------------------
-- Numbers
-----------------------------------------------------------
-- Returns tuple with the parsed lexeme, the integer, the amount of read characters and the rest of the text
getNumber :: String -> (Lexeme, (Either Int Double), Int, String)
getNumber str =
case readDec str of
[(_,('.':_))] -> case readFloat str of
[(flt,rest)] -> (LexFloat flt, Right flt, length str - length rest,rest)
_ -> fatal 342 "Unexpected: can read decimal, but not float???"
[(dec,rest)] -> (LexDecimal dec , Left dec, length str - length rest,rest)
_ -> fatal 343 $ "No number to read!\n " ++ take 40 str
--getNumber :: String -> (Lexeme, (Either Int Double), Int, String)
--getNumber [] = fatal 294 "getNumber"
--getNumber cs@(c:s)
-- | c /= '0' = num10
-- | null s = const0
-- | hs `elem` "xX" = num16
-- | hs `elem` "oO" = num8
-- | otherwise = num10
-- where (hs:ts) = s
-- const0 = (LexDecimal 0, Left 0, 1, s)
-- num10 :: (Lexeme, (Either Int Double), Int, String)
-- num10 = let (n, rs) = span isDigit cs
-- (isWhole,readed,rest) =
-- case rs of
-- '.':cs' -> let (n',rs') = span isDigit cs'
-- wholeNumberString = n++"."++n'
-- in (all (=='0') n',wholeNumberString,rs')
-- _ -> (True,n, rs)
-- nrInt = read n
-- in if isWhole
-- then (LexDecimal nrInt , Left nrInt, length readed,rest)
-- else let x = fst.head.readFloat $ readed
-- in (LexFloat x, Right x, length readed,rest)
-- num16 = readIntNum isHexaDigit 16 LexHex
-- num8 = readIntNum isOctDigit 8 LexOctal
-- readIntNum :: (Char -> Bool) -> Int -> (Int -> Lexeme) -> (Lexeme, Either Int a , Int, String)
-- readIntNum p base lx
-- = let (n, rs) = span p ts
-- in if null n
-- then const0
-- else let nr = readn base n
-- in (lx nr, Left nr, 2 + length n, rs)
-----------------------------------------------------------
-- characters / strings
-----------------------------------------------------------
scanString :: String -> (String, Int, String)
scanString = scanUpto False ['"']
scanSingletonInExpression :: String -> (String, Int, String)
scanSingletonInExpression = scanUpto True ['\'']
-- | scan to some given character. The end char is scanned away too
scanUpto :: Bool -- Special case for Ampersand Atomvalues? (if so, both singlequote and doublequote must be escaped)
-> [Char] -- non-empty list of ending characters
-> String
-> (String, Int, String)
scanUpto isAtomScan echrs s =
case s of
xs -> let (ch,cw,cr) = getchar isAtomScan echrs xs
(str,w,r) = scanUpto isAtomScan echrs cr
in maybe ("",0,xs) (\c -> (c:str,cw+w,r)) ch
getchar :: Bool -- Special case for Ampersand Atomvalues? (if so, both singlequote and doublequote must be escaped)
-> [Char] -- non-empty list of ending characters
-> String -- string to get the character from
-> (Maybe Char, Int, String)
getchar isAtomScan echrs s =
case s of
[] -> (Nothing,0,[])
('\n':_ ) -> (Nothing,0,s)
('\t':_ ) -> (Nothing,0,s)
('\\':'&':xs) -> let (str,w,r) = getchar isAtomScan echrs xs -- Special case is required because an escaped & is equal to empty string in Haskell
in (str,w+2,r)
('\\':xs) -> let (c,l,r) = getEscChar xs
in (c,l+1,r)
(x:xs)
| x `elem` echrs -> (Nothing,0,s)
| isAtomScan && x `elem`[doubleQuote, singleQuote] -> (Nothing,0,s)
--- | isAtomScan && ec == singleQuote && x == doubleQuote -> (Nothing,0,s)
| otherwise -> (Just x,1,xs)
where
(doubleQuote,singleQuote) = ('\"','\'')
getEscChar :: String -> (Maybe Char, Int, String)
getEscChar [] = (Nothing,0,[])
getEscChar s@(x:xs) | isDigit x = case readDec s of
[(val,rest)]
| val >= 0 && val <= 255 -> (Just (chr val),length s - length rest, rest)
| otherwise -> (Nothing, 1, rest)
_ -> fatal 432 $ "Impossible! first char is a digit.. "++take 40 s
| x `elem` ['\"','\''] = (Just x,2,xs)
| otherwise = case x `lookup` cntrChars of
Nothing -> (Nothing,0,s)
Just c -> (Just c,1,xs)
where cntrChars = [('a','\a'),('b','\b'),('f','\f'),('n','\n'),('r','\r'),('t','\t')
,('v','\v'),('\\','\\')]
-----------------------------------------------------------
-- Token creation function
-----------------------------------------------------------
returnToken :: Lexeme -> FilePos -> Lexer -> Lexer
returnToken lx pos continue posi input = do
let token = Tok lx pos
tokens <- continue posi input
return (token:tokens)