cryptol-2.12.0: src/Cryptol/Parser/LexerUtils.hs
-- |
-- Module : Cryptol.Parser.LexerUtils
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE OverloadedStrings #-}
module Cryptol.Parser.LexerUtils where
import Control.Monad(guard)
import Data.Char(toLower,generalCategory,isAscii,ord,isSpace,
isAlphaNum,isAlpha)
import qualified Data.Char as Char
import Data.Text(Text)
import qualified Data.Text as T
import qualified Data.Text.Read as T
import Data.Word(Word8)
import Cryptol.Utils.Panic
import Cryptol.Parser.Position
import Cryptol.Parser.Token
import Cryptol.Parser.Unlit(PreProc(None))
data Config = Config
{ cfgSource :: !FilePath -- ^ File that we are working on
, cfgStart :: !Position -- ^ Starting position for the parser
, cfgLayout :: !Layout -- ^ Settings for layout processing
, cfgPreProc :: PreProc -- ^ Preprocessor settings
, cfgAutoInclude :: [FilePath] -- ^ Implicit includes
, cfgModuleScope :: Bool -- ^ When we do layout processing
-- should we add a vCurly (i.e., are
-- we parsing a list of things).
}
defaultConfig :: Config
defaultConfig = Config
{ cfgSource = ""
, cfgStart = start
, cfgLayout = Layout
, cfgPreProc = None
, cfgAutoInclude = []
, cfgModuleScope = True
}
type Action = Config -> Position -> Text -> LexS
-> ([Located Token], LexS)
data LexS = Normal
| InComment Bool Position ![Position] [Text]
| InString Position Text
| InChar Position Text
startComment :: Bool -> Action
startComment isDoc _ p txt s = ([], InComment d p stack chunks)
where (d,stack,chunks) = case s of
Normal -> (isDoc, [], [txt])
InComment doc q qs cs -> (doc, q : qs, txt : cs)
_ -> panic "[Lexer] startComment" ["in a string"]
endComment :: Action
endComment cfg p txt s =
case s of
InComment d f [] cs -> ([mkToken d f cs], Normal)
InComment d _ (q:qs) cs -> ([], InComment d q qs (txt : cs))
_ -> panic "[Lexer] endComment" ["outside comment"]
where
mkToken isDoc f cs =
let r = Range { from = f, to = moves p txt, source = cfgSource cfg }
str = T.concat $ reverse $ txt : cs
tok = if isDoc then DocStr else BlockComment
in Located { srcRange = r, thing = Token (White tok) str }
addToComment :: Action
addToComment _ _ txt s = ([], InComment doc p stack (txt : chunks))
where
(doc, p, stack, chunks) =
case s of
InComment d q qs cs -> (d,q,qs,cs)
_ -> panic "[Lexer] addToComment" ["outside comment"]
startEndComment :: Action
startEndComment cfg p txt s =
case s of
Normal -> ([tok], Normal)
where tok = Located
{ srcRange = Range { from = p
, to = moves p txt
, source = cfgSource cfg
}
, thing = Token (White BlockComment) txt
}
InComment d p1 ps cs -> ([], InComment d p1 ps (txt : cs))
_ -> panic "[Lexer] startEndComment" ["in string or char?"]
startString :: Action
startString _ p txt _ = ([],InString p txt)
endString :: Action
endString cfg pe txt s = case s of
InString ps str -> ([mkToken ps str], Normal)
_ -> panic "[Lexer] endString" ["outside string"]
where
parseStr s1 = case reads s1 of
[(cs, "")] -> StrLit cs
_ -> Err InvalidString
mkToken ps str = Located { srcRange = Range
{ from = ps
, to = moves pe txt
, source = cfgSource cfg
}
, thing = Token
{ tokenType = parseStr (T.unpack tokStr)
, tokenText = tokStr
}
}
where
tokStr = str `T.append` txt
addToString :: Action
addToString _ _ txt s = case s of
InString p str -> ([],InString p (str `T.append` txt))
_ -> panic "[Lexer] addToString" ["outside string"]
startChar :: Action
startChar _ p txt _ = ([],InChar p txt)
endChar :: Action
endChar cfg pe txt s =
case s of
InChar ps str -> ([mkToken ps str], Normal)
_ -> panic "[Lexer] endString" ["outside character"]
where
parseChar s1 = case reads s1 of
[(cs, "")] -> ChrLit cs
_ -> Err InvalidChar
mkToken ps str = Located { srcRange = Range
{ from = ps
, to = moves pe txt
, source = cfgSource cfg
}
, thing = Token
{ tokenType = parseChar (T.unpack tokStr)
, tokenText = tokStr
}
}
where
tokStr = str `T.append` txt
addToChar :: Action
addToChar _ _ txt s = case s of
InChar p str -> ([],InChar p (str `T.append` txt))
_ -> panic "[Lexer] addToChar" ["outside character"]
mkIdent :: Action
mkIdent cfg p s z = ([Located { srcRange = r, thing = Token t s }], z)
where
r = Range { from = p, to = moves p s, source = cfgSource cfg }
t = Ident [] s
mkQualIdent :: Action
mkQualIdent cfg p s z = ([Located { srcRange = r, thing = Token t s}], z)
where
r = Range { from = p, to = moves p s, source = cfgSource cfg }
t = Ident ns i
(ns,i) = splitQual s
mkQualOp :: Action
mkQualOp cfg p s z = ([Located { srcRange = r, thing = Token t s}], z)
where
r = Range { from = p, to = moves p s, source = cfgSource cfg }
t = Op (Other ns i)
(ns,i) = splitQual s
emit :: TokenT -> Action
emit t cfg p s z = ([Located { srcRange = r, thing = Token t s }], z)
where r = Range { from = p, to = moves p s, source = cfgSource cfg }
emitS :: (Text -> TokenT) -> Action
emitS t cfg p s z = emit (t s) cfg p s z
emitFancy :: (FilePath -> Position -> Text -> [Located Token]) -> Action
emitFancy f = \cfg p s z -> (f (cfgSource cfg) p s, z)
-- | Split out the prefix and name part of an identifier/operator.
splitQual :: T.Text -> ([T.Text], T.Text)
splitQual t =
case splitNS (T.filter (not . isSpace) t) of
[] -> panic "[Lexer] mkQualIdent" ["invalid qualified name", show t]
[i] -> ([], i)
xs -> (init xs, last xs)
where
-- split on the namespace separator, `::`
splitNS s =
case T.breakOn "::" s of
(l,r) | T.null r -> [l]
| otherwise -> l : splitNS (T.drop 2 r)
--------------------------------------------------------------------------------
numToken :: Text -> TokenT
numToken ds = case toVal of
Just v -> Num v rad (T.length ds')
Nothing -> Err MalformedLiteral
where
rad
| "0b" `T.isPrefixOf` ds = 2
| "0o" `T.isPrefixOf` ds = 8
| "0x" `T.isPrefixOf` ds = 16
| otherwise = 10
ds1 = if rad == 10 then ds else T.drop 2 ds
ds' = T.filter (/= '_') ds1
toVal = T.foldl' step (Just 0) ds'
irad = toInteger rad
step mb x = do soFar <- mb
d <- fromDigit irad x
pure $! (irad * soFar + d)
fromDigit :: Integer -> Char -> Maybe Integer
fromDigit r x' =
do d <- v
guard (d < r)
pure d
where
x = toLower x'
v | '0' <= x && x <= '9' = Just $ toInteger $ fromEnum x - fromEnum '0'
| 'a' <= x && x <= 'z' = Just $ toInteger $ 10 + fromEnum x - fromEnum 'a'
| otherwise = Nothing
-- | Interpret something either as a fractional token,
-- a number followed by a selector, or an error.
fnumTokens :: FilePath -> Position -> Text -> [Located Token]
fnumTokens file pos ds =
case wholeNum of
Nothing -> [ tokFrom pos ds (Err MalformedLiteral) ]
Just i
| Just f <- fracNum, Just e <- expNum ->
[ tokFrom pos ds (Frac ((fromInteger i + f) * (eBase ^^ e)) rad) ]
| otherwise ->
[ tokFrom pos whole (Num i rad (T.length whole))
, tokFrom afterWhole rest (selectorToken rest)
]
where
tokFrom tpos txt t =
Located { srcRange =
Range { from = tpos, to = moves tpos txt, source = file }
, thing = Token { tokenText = txt, tokenType = t }
}
afterWhole = moves pos whole
rad
| "0b" `T.isPrefixOf` ds = 2
| "0o" `T.isPrefixOf` ds = 8
| "0x" `T.isPrefixOf` ds = 16
| otherwise = 10
radI = fromIntegral rad :: Integer
radR = fromIntegral rad :: Rational
(whole,rest) = T.break (== '.') (if rad == 10 then ds else T.drop 2 ds)
digits = T.filter (/= '_')
expSym e = if rad == 10 then toLower e == 'e' else toLower e == 'p'
(frac,mbExp) = T.break expSym (T.drop 1 rest)
wholeStep mb c = do soFar <- mb
d <- fromDigit radI c
pure $! (radI * soFar + d)
wholeNum = T.foldl' wholeStep (Just 0) (digits whole)
fracStep mb c = do soFar <- mb
d <- fromInteger <$> fromDigit radI c
pure $! ((soFar + d) / radR)
fracNum = do let fds = T.reverse (digits frac)
guard (T.length fds > 0)
T.foldl' fracStep (Just 0) fds
expNum = case T.uncons mbExp of
Nothing -> Just (0 :: Integer)
Just (_,es) ->
case T.uncons es of
Just ('+', more) -> readDecimal more
Just ('-', more) -> negate <$> readDecimal more
_ -> readDecimal es
eBase = if rad == 10 then 10 else 2 :: Rational
-- assumes we start with a dot
selectorToken :: Text -> TokenT
selectorToken txt
| Just n <- readDecimal body, n >= 0 = Selector (TupleSelectorTok n)
| Just (x,xs) <- T.uncons body
, id_first x
, T.all id_next xs = Selector (RecordSelectorTok body)
| otherwise = Err MalformedSelector
where
body = T.drop 1 txt
id_first x = isAlpha x || x == '_'
id_next x = isAlphaNum x || x == '_' || x == '\''
readDecimal :: Integral a => Text -> Maybe a
readDecimal txt = case T.decimal txt of
Right (a,more) | T.null more -> Just a
_ -> Nothing
-------------------------------------------------------------------------------
data AlexInput = Inp { alexPos :: !Position
, alexInputPrevChar :: !Char
, input :: !Text
} deriving Show
alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)
alexGetByte i =
do (c,rest) <- T.uncons (input i)
let i' = i { alexPos = move (alexPos i) c, input = rest }
b = byteForChar c
return (b,i')
data Layout = Layout | NoLayout
--------------------------------------------------------------------------------
-- | Drop white-space tokens from the input.
dropWhite :: [Located Token] -> [Located Token]
dropWhite = filter (notWhite . tokenType . thing)
where notWhite (White w) = w == DocStr
notWhite _ = True
-- | Collapse characters into a single Word8, identifying ASCII, and classes of
-- unicode. This came from:
--
-- https://github.com/glguy/config-value/blob/master/src/Config/LexerUtils.hs
--
-- Which adapted:
--
-- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x
byteForChar :: Char -> Word8
byteForChar c
| c <= '\6' = non_graphic
| isAscii c = fromIntegral (ord c)
| otherwise = case generalCategory c of
Char.LowercaseLetter -> lower
Char.OtherLetter -> lower
Char.UppercaseLetter -> upper
Char.TitlecaseLetter -> upper
Char.DecimalNumber -> digit
Char.OtherNumber -> digit
Char.ConnectorPunctuation -> symbol
Char.DashPunctuation -> symbol
Char.OtherPunctuation -> symbol
Char.MathSymbol -> symbol
Char.CurrencySymbol -> symbol
Char.ModifierSymbol -> symbol
Char.OtherSymbol -> symbol
Char.Space -> sp
Char.ModifierLetter -> other
Char.NonSpacingMark -> other
Char.SpacingCombiningMark -> other
Char.EnclosingMark -> other
Char.LetterNumber -> other
Char.OpenPunctuation -> other
Char.ClosePunctuation -> other
Char.InitialQuote -> other
Char.FinalQuote -> tick
_ -> non_graphic
where
non_graphic = 0
upper = 1
lower = 2
digit = 3
symbol = 4
sp = 5
other = 6
tick = 7