-- |
-- 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
  { Config -> FilePath
cfgSource      :: !FilePath     -- ^ File that we are working on
  , Config -> Position
cfgStart       :: !Position     -- ^ Starting position for the parser
  , Config -> Layout
cfgLayout      :: !Layout       -- ^ Settings for layout processing
  , Config -> PreProc
cfgPreProc     :: PreProc       -- ^ Preprocessor settings
  , Config -> [FilePath]
cfgAutoInclude :: [FilePath]    -- ^ Implicit includes
  , Config -> Bool
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
defaultConfig  = Config
  { cfgSource :: FilePath
cfgSource      = FilePath
""
  , cfgStart :: Position
cfgStart       = Position
start
  , cfgLayout :: Layout
cfgLayout      = Layout
Layout
  , cfgPreProc :: PreProc
cfgPreProc     = PreProc
None
  , cfgAutoInclude :: [FilePath]
cfgAutoInclude = []
  , cfgModuleScope :: Bool
cfgModuleScope = Bool
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 :: Bool -> Action
startComment Bool
isDoc Config
_ Position
p Text
txt LexS
s = ([], Bool -> Position -> [Position] -> [Text] -> LexS
InComment Bool
d Position
p [Position]
stack [Text]
chunks)
  where (Bool
d,[Position]
stack,[Text]
chunks) = case LexS
s of
                           LexS
Normal                -> (Bool
isDoc, [], [Text
txt])
                           InComment Bool
doc Position
q [Position]
qs [Text]
cs -> (Bool
doc, Position
q Position -> [Position] -> [Position]
forall a. a -> [a] -> [a]
: [Position]
qs, Text
txt Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
cs)
                           LexS
_                     -> FilePath -> [FilePath] -> (Bool, [Position], [Text])
forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"[Lexer] startComment" [FilePath
"in a string"]

endComment :: Action
endComment :: Action
endComment Config
cfg Position
p Text
txt LexS
s =
  case LexS
s of
    InComment Bool
d Position
f [] [Text]
cs     -> ([Bool -> Position -> [Text] -> Located Token
mkToken Bool
d Position
f [Text]
cs], LexS
Normal)
    InComment Bool
d Position
_ (Position
q:[Position]
qs) [Text]
cs -> ([], Bool -> Position -> [Position] -> [Text] -> LexS
InComment Bool
d Position
q [Position]
qs (Text
txt Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
cs))
    LexS
_                     -> FilePath -> [FilePath] -> ([Located Token], LexS)
forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"[Lexer] endComment" [FilePath
"outside comment"]
  where
  mkToken :: Bool -> Position -> [Text] -> Located Token
mkToken Bool
isDoc Position
f [Text]
cs =
    let r :: Range
r   = Range { from :: Position
from = Position
f, to :: Position
to = Position -> Text -> Position
moves Position
p Text
txt, source :: FilePath
source = Config -> FilePath
cfgSource Config
cfg }
        str :: Text
str = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text
txt Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
cs

        tok :: TokenW
tok = if Bool
isDoc then TokenW
DocStr else TokenW
BlockComment
    in Located { srcRange :: Range
srcRange = Range
r, thing :: Token
thing = TokenT -> Text -> Token
Token (TokenW -> TokenT
White TokenW
tok) Text
str }

addToComment :: Action
addToComment :: Action
addToComment Config
_ Position
_ Text
txt LexS
s = ([], Bool -> Position -> [Position] -> [Text] -> LexS
InComment Bool
doc Position
p [Position]
stack (Text
txt Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
chunks))
  where
  (Bool
doc, Position
p, [Position]
stack, [Text]
chunks) =
     case LexS
s of
       InComment Bool
d Position
q [Position]
qs [Text]
cs -> (Bool
d,Position
q,[Position]
qs,[Text]
cs)
       LexS
_                   -> FilePath -> [FilePath] -> (Bool, Position, [Position], [Text])
forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"[Lexer] addToComment" [FilePath
"outside comment"]

startEndComment :: Action
startEndComment :: Action
startEndComment Config
cfg Position
p Text
txt LexS
s =
  case LexS
s of
    LexS
Normal -> ([Located Token
tok], LexS
Normal)
      where tok :: Located Token
tok = Located
                    { srcRange :: Range
srcRange = Range { from :: Position
from   = Position
p
                                       , to :: Position
to     = Position -> Text -> Position
moves Position
p Text
txt
                                       , source :: FilePath
source = Config -> FilePath
cfgSource Config
cfg
                                       }
                    , thing :: Token
thing = TokenT -> Text -> Token
Token (TokenW -> TokenT
White TokenW
BlockComment) Text
txt
                    }
    InComment Bool
d Position
p1 [Position]
ps [Text]
cs -> ([], Bool -> Position -> [Position] -> [Text] -> LexS
InComment Bool
d Position
p1 [Position]
ps (Text
txt Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
cs))
    LexS
_ -> FilePath -> [FilePath] -> ([Located Token], LexS)
forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"[Lexer] startEndComment" [FilePath
"in string or char?"]

startString :: Action
startString :: Action
startString Config
_ Position
p Text
txt LexS
_ = ([],Position -> Text -> LexS
InString Position
p Text
txt)

endString :: Action
endString :: Action
endString Config
cfg Position
pe Text
txt LexS
s = case LexS
s of
  InString Position
ps Text
str -> ([Position -> Text -> Located Token
mkToken Position
ps Text
str], LexS
Normal)
  LexS
_               -> FilePath -> [FilePath] -> ([Located Token], LexS)
forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"[Lexer] endString" [FilePath
"outside string"]
  where
  parseStr :: FilePath -> TokenT
parseStr FilePath
s1 = case ReadS FilePath
forall a. Read a => ReadS a
reads FilePath
s1 of
                  [(FilePath
cs, FilePath
"")] -> FilePath -> TokenT
StrLit FilePath
cs
                  [(FilePath, FilePath)]
_          -> TokenErr -> TokenT
Err TokenErr
InvalidString

  mkToken :: Position -> Text -> Located Token
mkToken Position
ps Text
str = Located { srcRange :: Range
srcRange = Range
                               { from :: Position
from   = Position
ps
                               , to :: Position
to     = Position -> Text -> Position
moves Position
pe Text
txt
                               , source :: FilePath
source = Config -> FilePath
cfgSource Config
cfg
                               }
                           , thing :: Token
thing    = Token
                               { tokenType :: TokenT
tokenType = FilePath -> TokenT
parseStr (Text -> FilePath
T.unpack Text
tokStr)
                               , tokenText :: Text
tokenText = Text
tokStr
                               }
                           }
    where
    tokStr :: Text
tokStr = Text
str Text -> Text -> Text
`T.append` Text
txt


addToString :: Action
addToString :: Action
addToString Config
_ Position
_ Text
txt LexS
s = case LexS
s of
  InString Position
p Text
str -> ([],Position -> Text -> LexS
InString Position
p (Text
str Text -> Text -> Text
`T.append` Text
txt))
  LexS
_              -> FilePath -> [FilePath] -> ([Located Token], LexS)
forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"[Lexer] addToString" [FilePath
"outside string"]


startChar :: Action
startChar :: Action
startChar Config
_ Position
p Text
txt LexS
_   = ([],Position -> Text -> LexS
InChar Position
p Text
txt)

endChar :: Action
endChar :: Action
endChar Config
cfg Position
pe Text
txt LexS
s =
  case LexS
s of
    InChar Position
ps Text
str -> ([Position -> Text -> Located Token
mkToken Position
ps Text
str], LexS
Normal)
    LexS
_             -> FilePath -> [FilePath] -> ([Located Token], LexS)
forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"[Lexer] endString" [FilePath
"outside character"]

  where
  parseChar :: FilePath -> TokenT
parseChar FilePath
s1 = case ReadS Char
forall a. Read a => ReadS a
reads FilePath
s1 of
                   [(Char
cs, FilePath
"")] -> Char -> TokenT
ChrLit Char
cs
                   [(Char, FilePath)]
_          -> TokenErr -> TokenT
Err TokenErr
InvalidChar

  mkToken :: Position -> Text -> Located Token
mkToken Position
ps Text
str = Located { srcRange :: Range
srcRange = Range
                               { from :: Position
from   = Position
ps
                               , to :: Position
to     = Position -> Text -> Position
moves Position
pe Text
txt
                               , source :: FilePath
source = Config -> FilePath
cfgSource Config
cfg
                               }
                           , thing :: Token
thing    = Token
                               { tokenType :: TokenT
tokenType = FilePath -> TokenT
parseChar (Text -> FilePath
T.unpack Text
tokStr)
                               , tokenText :: Text
tokenText = Text
tokStr
                               }
                           }
    where
    tokStr :: Text
tokStr = Text
str Text -> Text -> Text
`T.append` Text
txt



addToChar :: Action
addToChar :: Action
addToChar Config
_ Position
_ Text
txt LexS
s = case LexS
s of
  InChar Position
p Text
str -> ([],Position -> Text -> LexS
InChar Position
p (Text
str Text -> Text -> Text
`T.append` Text
txt))
  LexS
_              -> FilePath -> [FilePath] -> ([Located Token], LexS)
forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"[Lexer] addToChar" [FilePath
"outside character"]


mkIdent :: Action
mkIdent :: Action
mkIdent Config
cfg Position
p Text
s LexS
z = ([Located { srcRange :: Range
srcRange = Range
r, thing :: Token
thing = TokenT -> Text -> Token
Token TokenT
t Text
s }], LexS
z)
  where
  r :: Range
r = Range { from :: Position
from = Position
p, to :: Position
to = Position -> Text -> Position
moves Position
p Text
s, source :: FilePath
source = Config -> FilePath
cfgSource Config
cfg }
  t :: TokenT
t = [Text] -> Text -> TokenT
Ident [] Text
s

mkQualIdent :: Action
mkQualIdent :: Action
mkQualIdent Config
cfg Position
p Text
s LexS
z = ([Located { srcRange :: Range
srcRange = Range
r, thing :: Token
thing = TokenT -> Text -> Token
Token TokenT
t Text
s}], LexS
z)
  where
  r :: Range
r = Range { from :: Position
from = Position
p, to :: Position
to = Position -> Text -> Position
moves Position
p Text
s, source :: FilePath
source = Config -> FilePath
cfgSource Config
cfg }
  t :: TokenT
t = [Text] -> Text -> TokenT
Ident [Text]
ns Text
i
  ([Text]
ns,Text
i) = Text -> ([Text], Text)
splitQual Text
s

mkQualOp :: Action
mkQualOp :: Action
mkQualOp Config
cfg Position
p Text
s LexS
z = ([Located { srcRange :: Range
srcRange = Range
r, thing :: Token
thing = TokenT -> Text -> Token
Token TokenT
t Text
s}], LexS
z)
  where
  r :: Range
r = Range { from :: Position
from = Position
p, to :: Position
to = Position -> Text -> Position
moves Position
p Text
s, source :: FilePath
source = Config -> FilePath
cfgSource Config
cfg }
  t :: TokenT
t = TokenOp -> TokenT
Op ([Text] -> Text -> TokenOp
Other [Text]
ns Text
i)
  ([Text]
ns,Text
i) = Text -> ([Text], Text)
splitQual Text
s

emit :: TokenT -> Action
emit :: TokenT -> Action
emit TokenT
t Config
cfg Position
p Text
s LexS
z  = ([Located { srcRange :: Range
srcRange = Range
r, thing :: Token
thing = TokenT -> Text -> Token
Token TokenT
t Text
s }], LexS
z)
  where r :: Range
r = Range { from :: Position
from = Position
p, to :: Position
to = Position -> Text -> Position
moves Position
p Text
s, source :: FilePath
source = Config -> FilePath
cfgSource Config
cfg }

emitS :: (Text -> TokenT) -> Action
emitS :: (Text -> TokenT) -> Action
emitS Text -> TokenT
t Config
cfg Position
p Text
s LexS
z  = TokenT -> Action
emit (Text -> TokenT
t Text
s) Config
cfg Position
p Text
s LexS
z

emitFancy :: (FilePath -> Position -> Text -> [Located Token]) -> Action
emitFancy :: (FilePath -> Position -> Text -> [Located Token]) -> Action
emitFancy FilePath -> Position -> Text -> [Located Token]
f = \Config
cfg Position
p Text
s LexS
z -> (FilePath -> Position -> Text -> [Located Token]
f (Config -> FilePath
cfgSource Config
cfg) Position
p Text
s, LexS
z)


-- | Split out the prefix and name part of an identifier/operator.
splitQual :: T.Text -> ([T.Text], T.Text)
splitQual :: Text -> ([Text], Text)
splitQual Text
t =
  case Text -> [Text]
splitNS ((Char -> Bool) -> Text -> Text
T.filter (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) Text
t) of
    []  -> FilePath -> [FilePath] -> ([Text], Text)
forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"[Lexer] mkQualIdent" [FilePath
"invalid qualified name", Text -> FilePath
forall a. Show a => a -> FilePath
show Text
t]
    [Text
i] -> ([], Text
i)
    [Text]
xs  -> ([Text] -> [Text]
forall a. HasCallStack => [a] -> [a]
init [Text]
xs, [Text] -> Text
forall a. HasCallStack => [a] -> a
last [Text]
xs)

  where

  -- split on the namespace separator, `::`
  splitNS :: Text -> [Text]
splitNS Text
s =
    case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"::" Text
s of
      (Text
l,Text
r) | Text -> Bool
T.null Text
r  -> [Text
l]
            | Bool
otherwise -> Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text -> [Text]
splitNS (Int -> Text -> Text
T.drop Int
2 Text
r)



--------------------------------------------------------------------------------
numToken :: Text -> TokenT
numToken :: Text -> TokenT
numToken Text
ds = case Maybe Integer
toVal of
                Just Integer
v  -> Integer -> Int -> Int -> TokenT
Num Integer
v Int
rad (Text -> Int
T.length Text
ds')
                Maybe Integer
Nothing -> TokenErr -> TokenT
Err TokenErr
MalformedLiteral
  where
  rad :: Int
rad
    | Text
"0b" Text -> Text -> Bool
`T.isPrefixOf` Text
ds = Int
2
    | Text
"0o" Text -> Text -> Bool
`T.isPrefixOf` Text
ds = Int
8
    | Text
"0x" Text -> Text -> Bool
`T.isPrefixOf` Text
ds = Int
16
    | Bool
otherwise              = Int
10

  ds1 :: Text
ds1   = if Int
rad Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
10 then Text
ds else Int -> Text -> Text
T.drop Int
2 Text
ds

  ds' :: Text
ds'   = (Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_') Text
ds1
  toVal :: Maybe Integer
toVal = (Maybe Integer -> Char -> Maybe Integer)
-> Maybe Integer -> Text -> Maybe Integer
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' Maybe Integer -> Char -> Maybe Integer
step (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
0) Text
ds'
  irad :: Integer
irad  = Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
rad
  step :: Maybe Integer -> Char -> Maybe Integer
step Maybe Integer
mb Char
x = do Integer
soFar <- Maybe Integer
mb
                 Integer
d     <- Integer -> Char -> Maybe Integer
fromDigit Integer
irad Char
x
                 Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$! (Integer
irad Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
soFar Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
d)

fromDigit :: Integer -> Char -> Maybe Integer
fromDigit :: Integer -> Char -> Maybe Integer
fromDigit Integer
r Char
x' =
  do Integer
d <- Maybe Integer
v
     Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
d Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
r)
     Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
d
  where
  x :: Char
x = Char -> Char
toLower Char
x'
  v :: Maybe Integer
v | Char
'0' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
x Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$      Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'0'
    | Char
'a' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
x Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z' = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'a'
    | Bool
otherwise            = Maybe Integer
forall a. Maybe a
Nothing


-- | Interpret something either as a fractional token,
-- a number followed by a selector, or an error.
fnumTokens :: FilePath -> Position -> Text -> [Located Token]
fnumTokens :: FilePath -> Position -> Text -> [Located Token]
fnumTokens FilePath
file Position
pos Text
ds =
  case Maybe Integer
wholeNum of
    Maybe Integer
Nothing -> [ Position -> Text -> TokenT -> Located Token
tokFrom Position
pos Text
ds (TokenErr -> TokenT
Err TokenErr
MalformedLiteral) ]
    Just Integer
i
      | Just Rational
f <- Maybe Rational
fracNum, Just Integer
e <- Maybe Integer
expNum ->
        [ Position -> Text -> TokenT -> Located Token
tokFrom Position
pos Text
ds (Rational -> Int -> TokenT
Frac ((Integer -> Rational
forall a. Num a => Integer -> a
fromInteger Integer
i Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
f) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (Rational
eBase Rational -> Integer -> Rational
forall a b. (Fractional a, Integral b) => a -> b -> a
^^ Integer
e)) Int
rad) ]
      | Bool
otherwise ->
        [ Position -> Text -> TokenT -> Located Token
tokFrom Position
pos        Text
whole (Integer -> Int -> Int -> TokenT
Num Integer
i Int
rad (Text -> Int
T.length Text
whole))
        , Position -> Text -> TokenT -> Located Token
tokFrom Position
afterWhole Text
rest  (Text -> TokenT
selectorToken Text
rest)
        ]

  where
  tokFrom :: Position -> Text -> TokenT -> Located Token
tokFrom Position
tpos Text
txt TokenT
t =
    Located { srcRange :: Range
srcRange =
                 Range { from :: Position
from = Position
tpos, to :: Position
to = Position -> Text -> Position
moves Position
tpos Text
txt, source :: FilePath
source = FilePath
file }
            , thing :: Token
thing = Token { tokenText :: Text
tokenText = Text
txt, tokenType :: TokenT
tokenType = TokenT
t }
            }

  afterWhole :: Position
afterWhole = Position -> Text -> Position
moves Position
pos Text
whole

  rad :: Int
rad
    | Text
"0b" Text -> Text -> Bool
`T.isPrefixOf` Text
ds = Int
2
    | Text
"0o" Text -> Text -> Bool
`T.isPrefixOf` Text
ds = Int
8
    | Text
"0x" Text -> Text -> Bool
`T.isPrefixOf` Text
ds = Int
16
    | Bool
otherwise              = Int
10

  radI :: Integer
radI           = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rad :: Integer
  radR :: Rational
radR           = Int -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rad :: Rational

  (Text
whole,Text
rest)   = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') (if Int
rad Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
10 then Text
ds else Int -> Text -> Text
T.drop Int
2 Text
ds)
  digits :: Text -> Text
digits         = (Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_')
  expSym :: Char -> Bool
expSym Char
e       = if Int
rad Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
10 then Char -> Char
toLower Char
e Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'e' else Char -> Char
toLower Char
e Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'p'
  (Text
frac,Text
mbExp)   = (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
expSym (Int -> Text -> Text
T.drop Int
1 Text
rest)

  wholeStep :: Maybe Integer -> Char -> Maybe Integer
wholeStep Maybe Integer
mb Char
c = do Integer
soFar <- Maybe Integer
mb
                      Integer
d     <- Integer -> Char -> Maybe Integer
fromDigit Integer
radI Char
c
                      Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$! (Integer
radI Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
soFar Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
d)

  wholeNum :: Maybe Integer
wholeNum       = (Maybe Integer -> Char -> Maybe Integer)
-> Maybe Integer -> Text -> Maybe Integer
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' Maybe Integer -> Char -> Maybe Integer
wholeStep (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
0) (Text -> Text
digits Text
whole)

  fracStep :: Maybe Rational -> Char -> Maybe Rational
fracStep Maybe Rational
mb Char
c  = do Rational
soFar <- Maybe Rational
mb
                      Rational
d     <- Integer -> Rational
forall a. Num a => Integer -> a
fromInteger (Integer -> Rational) -> Maybe Integer -> Maybe Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Char -> Maybe Integer
fromDigit Integer
radI Char
c
                      Rational -> Maybe Rational
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rational -> Maybe Rational) -> Rational -> Maybe Rational
forall a b. (a -> b) -> a -> b
$! ((Rational
soFar Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
d) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
radR)

  fracNum :: Maybe Rational
fracNum        = do let fds :: Text
fds = Text -> Text
T.reverse (Text -> Text
digits Text
frac)
                      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text -> Int
T.length Text
fds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)
                      (Maybe Rational -> Char -> Maybe Rational)
-> Maybe Rational -> Text -> Maybe Rational
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' Maybe Rational -> Char -> Maybe Rational
fracStep (Rational -> Maybe Rational
forall a. a -> Maybe a
Just Rational
0) Text
fds

  expNum :: Maybe Integer
expNum         = case Text -> Maybe (Char, Text)
T.uncons Text
mbExp of
                     Maybe (Char, Text)
Nothing -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer
0 :: Integer)
                     Just (Char
_,Text
es) ->
                       case Text -> Maybe (Char, Text)
T.uncons Text
es of
                         Just (Char
'+', Text
more) -> Text -> Maybe Integer
forall a. Integral a => Text -> Maybe a
readDecimal Text
more
                         Just (Char
'-', Text
more) -> Integer -> Integer
forall a. Num a => a -> a
negate (Integer -> Integer) -> Maybe Integer -> Maybe Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Integer
forall a. Integral a => Text -> Maybe a
readDecimal Text
more
                         Maybe (Char, Text)
_                -> Text -> Maybe Integer
forall a. Integral a => Text -> Maybe a
readDecimal Text
es

  eBase :: Rational
eBase          = if Int
rad Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
10 then Rational
10 else Rational
2 :: Rational


-- assumes we start with a dot
selectorToken :: Text -> TokenT
selectorToken :: Text -> TokenT
selectorToken Text
txt
  | Just Int
n <- Text -> Maybe Int
forall a. Integral a => Text -> Maybe a
readDecimal Text
body, Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 = SelectorType -> TokenT
Selector (Int -> SelectorType
TupleSelectorTok Int
n)
  | Just (Char
x,Text
xs) <- Text -> Maybe (Char, Text)
T.uncons Text
body
  , Char -> Bool
id_first Char
x
  , (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
id_next Text
xs = SelectorType -> TokenT
Selector (Text -> SelectorType
RecordSelectorTok Text
body)
  | Bool
otherwise = TokenErr -> TokenT
Err TokenErr
MalformedSelector

  where
  body :: Text
body = Int -> Text -> Text
T.drop Int
1 Text
txt
  id_first :: Char -> Bool
id_first Char
x = Char -> Bool
isAlpha Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
  id_next :: Char -> Bool
id_next  Char
x = Char -> Bool
isAlphaNum Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''


readDecimal :: Integral a => Text -> Maybe a
readDecimal :: forall a. Integral a => Text -> Maybe a
readDecimal Text
txt = case Reader a
forall a. Integral a => Reader a
T.decimal Text
txt of
                    Right (a
a,Text
more) | Text -> Bool
T.null Text
more -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
                    Either FilePath (a, Text)
_ -> Maybe a
forall a. Maybe a
Nothing


-------------------------------------------------------------------------------

data AlexInput            = Inp { AlexInput -> Position
alexPos           :: !Position
                                , AlexInput -> Char
alexInputPrevChar :: !Char
                                , AlexInput -> Text
input             :: !Text
                                } deriving Int -> AlexInput -> ShowS
[AlexInput] -> ShowS
AlexInput -> FilePath
(Int -> AlexInput -> ShowS)
-> (AlexInput -> FilePath)
-> ([AlexInput] -> ShowS)
-> Show AlexInput
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AlexInput -> ShowS
showsPrec :: Int -> AlexInput -> ShowS
$cshow :: AlexInput -> FilePath
show :: AlexInput -> FilePath
$cshowList :: [AlexInput] -> ShowS
showList :: [AlexInput] -> ShowS
Show

alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)
alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)
alexGetByte AlexInput
i =
  do (Char
c,Text
rest) <- Text -> Maybe (Char, Text)
T.uncons (AlexInput -> Text
input AlexInput
i)
     let i' :: AlexInput
i' = AlexInput
i { alexPos = move (alexPos i) c, input = rest }
         b :: Word8
b  = Char -> Word8
byteForChar Char
c
     (Word8, AlexInput) -> Maybe (Word8, AlexInput)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word8
b, AlexInput
i')

data Layout = Layout | NoLayout


--------------------------------------------------------------------------------

-- | Drop white-space tokens from the input.
dropWhite :: [Located Token] -> [Located Token]
dropWhite :: [Located Token] -> [Located Token]
dropWhite = (Located Token -> Bool) -> [Located Token] -> [Located Token]
forall a. (a -> Bool) -> [a] -> [a]
filter (TokenT -> Bool
notWhite (TokenT -> Bool)
-> (Located Token -> TokenT) -> Located Token -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> TokenT
tokenType (Token -> TokenT)
-> (Located Token -> Token) -> Located Token -> TokenT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located Token -> Token
forall a. Located a -> a
thing)
  where notWhite :: TokenT -> Bool
notWhite (White TokenW
w) = TokenW
w TokenW -> TokenW -> Bool
forall a. Eq a => a -> a -> Bool
== TokenW
DocStr
        notWhite TokenT
_         = Bool
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 :: Char -> Word8
byteForChar Char
c
  | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\6' = Word8
non_graphic
  | Char -> Bool
isAscii Char
c = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c)
  | Bool
otherwise = case Char -> GeneralCategory
generalCategory Char
c of
                  GeneralCategory
Char.LowercaseLetter       -> Word8
lower
                  GeneralCategory
Char.OtherLetter           -> Word8
lower
                  GeneralCategory
Char.UppercaseLetter       -> Word8
upper
                  GeneralCategory
Char.TitlecaseLetter       -> Word8
upper
                  GeneralCategory
Char.DecimalNumber         -> Word8
digit
                  GeneralCategory
Char.OtherNumber           -> Word8
digit
                  GeneralCategory
Char.ConnectorPunctuation  -> Word8
symbol
                  GeneralCategory
Char.DashPunctuation       -> Word8
symbol
                  GeneralCategory
Char.OtherPunctuation      -> Word8
symbol
                  GeneralCategory
Char.MathSymbol            -> Word8
symbol
                  GeneralCategory
Char.CurrencySymbol        -> Word8
symbol
                  GeneralCategory
Char.ModifierSymbol        -> Word8
symbol
                  GeneralCategory
Char.OtherSymbol           -> Word8
symbol
                  GeneralCategory
Char.Space                 -> Word8
sp
                  GeneralCategory
Char.ModifierLetter        -> Word8
other
                  GeneralCategory
Char.NonSpacingMark        -> Word8
other
                  GeneralCategory
Char.SpacingCombiningMark  -> Word8
other
                  GeneralCategory
Char.EnclosingMark         -> Word8
other
                  GeneralCategory
Char.LetterNumber          -> Word8
other
                  GeneralCategory
Char.OpenPunctuation       -> Word8
other
                  GeneralCategory
Char.ClosePunctuation      -> Word8
other
                  GeneralCategory
Char.InitialQuote          -> Word8
other
                  GeneralCategory
Char.FinalQuote            -> Word8
tick
                  GeneralCategory
_                          -> Word8
non_graphic
  where
  non_graphic :: Word8
non_graphic     = Word8
0
  upper :: Word8
upper           = Word8
1
  lower :: Word8
lower           = Word8
2
  digit :: Word8
digit           = Word8
3
  symbol :: Word8
symbol          = Word8
4
  sp :: Word8
sp              = Word8
5
  other :: Word8
other           = Word8
6
  tick :: Word8
tick            = Word8
7