-- |
-- Module      :  Cryptol.Parser.LexerUtils
-- Copyright   :  (c) 2013-2016 Galois, Inc.
-- License     :  BSD3
-- Maintainer  :  cryptol@galois.com
-- Stability   :  provisional
-- Portability :  portable

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE BlockArguments #-}
module Cryptol.Parser.LexerUtils where

import Cryptol.Parser.Position
import Cryptol.Parser.Unlit(PreProc(None))
import Cryptol.Utils.PP
import Cryptol.Utils.Panic

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 GHC.Generics (Generic)
import Control.DeepSeq

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 :: FilePath
-> Position -> Layout -> PreProc -> [FilePath] -> Bool -> Config
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 :: Position -> Position -> FilePath -> Range
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 :: forall a. Range -> a -> Located a
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 :: forall a. Range -> a -> Located a
Located
                    { srcRange :: Range
srcRange = Range :: Position -> Position -> FilePath -> Range
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 :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range :: Position -> Position -> FilePath -> Range
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 :: TokenT -> Text -> Token
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 :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range :: Position -> Position -> FilePath -> Range
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 :: TokenT -> Text -> Token
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 :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range
r, thing :: Token
thing = TokenT -> Text -> Token
Token TokenT
t Text
s }], LexS
z)
  where
  r :: Range
r = Range :: Position -> Position -> FilePath -> Range
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 :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range
r, thing :: Token
thing = TokenT -> Text -> Token
Token TokenT
t Text
s}], LexS
z)
  where
  r :: Range
r = Range :: Position -> Position -> FilePath -> Range
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 :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range
r, thing :: Token
thing = TokenT -> Text -> Token
Token TokenT
t Text
s}], LexS
z)
  where
  r :: Range
r = Range :: Position -> Position -> FilePath -> Range
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 :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range
r, thing :: Token
thing = TokenT -> Text -> Token
Token TokenT
t Text
s }], LexS
z)
  where r :: Range
r = Range :: Position -> Position -> FilePath -> Range
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. [a] -> [a]
init [Text]
xs, [Text] -> Text
forall a. [a] -> a
last [Text]
xs)

  where

  -- split on the namespace separator, `::`
  splitNS :: Text -> [Text]
splitNS Text
s =
    case 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 (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 (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 :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange =
                 Range :: Position -> Position -> FilePath -> Range
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 :: TokenT -> Text -> Token
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 (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 (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 :: 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
showList :: [AlexInput] -> ShowS
$cshowList :: [AlexInput] -> ShowS
show :: AlexInput -> FilePath
$cshow :: AlexInput -> FilePath
showsPrec :: Int -> AlexInput -> ShowS
$cshowsPrec :: Int -> 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 :: Position
alexPos = Position -> Char -> Position
move (AlexInput -> Position
alexPos AlexInput
i) Char
c, input :: Text
input = Text
rest }
         b :: Word8
b  = Char -> Word8
byteForChar Char
c
     (Word8, AlexInput) -> Maybe (Word8, AlexInput)
forall (m :: * -> *) a. Monad m => a -> m a
return (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


data Block = Virtual Int     -- ^ Virtual layout block
           | Explicit TokenT -- ^ An explicit layout block, expecting this ending
                             -- token.
             deriving (Int -> Block -> ShowS
[Block] -> ShowS
Block -> FilePath
(Int -> Block -> ShowS)
-> (Block -> FilePath) -> ([Block] -> ShowS) -> Show Block
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Block] -> ShowS
$cshowList :: [Block] -> ShowS
show :: Block -> FilePath
$cshow :: Block -> FilePath
showsPrec :: Int -> Block -> ShowS
$cshowsPrec :: Int -> Block -> ShowS
Show)

isExplicit :: Block -> Bool
isExplicit :: Block -> Bool
isExplicit Explicit{} = Bool
True
isExplicit Virtual{}  = Bool
False

startsLayout :: TokenT -> Bool
startsLayout :: TokenT -> Bool
startsLayout (KW TokenKW
KW_where)    = Bool
True
startsLayout (KW TokenKW
KW_private)  = Bool
True
startsLayout (KW TokenKW
KW_parameter) = Bool
True
startsLayout TokenT
_                = Bool
False

-- Add separators computed from layout
layout :: Config -> [Located Token] -> [Located Token]
layout :: Config -> [Located Token] -> [Located Token]
layout Config
cfg [Located Token]
ts0 = Bool -> Bool -> [Block] -> [Located Token] -> [Located Token]
loop Bool
False Bool
implicitScope [] [Located Token]
ts0
  where

  (Position
_pos0,Bool
implicitScope) = case [Located Token]
ts0 of
    Located Token
t : [Located Token]
_ -> (Range -> Position
from (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
t), Config -> Bool
cfgModuleScope Config
cfg Bool -> Bool -> Bool
&& Token -> TokenT
tokenType (Located Token -> Token
forall a. Located a -> a
thing Located Token
t) TokenT -> TokenT -> Bool
forall a. Eq a => a -> a -> Bool
/= TokenKW -> TokenT
KW TokenKW
KW_module)
    [Located Token]
_     -> (Position
start,Bool
False)


  loop :: Bool -> Bool -> [Block] -> [Located Token] -> [Located Token]
  loop :: Bool -> Bool -> [Block] -> [Located Token] -> [Located Token]
loop Bool
afterDoc Bool
startBlock [Block]
stack (Located Token
t : [Located Token]
ts)
    | TokenT -> Bool
startsLayout TokenT
ty    = [Located Token]
toks [Located Token] -> [Located Token] -> [Located Token]
forall a. [a] -> [a] -> [a]
++ Bool -> Bool -> [Block] -> [Located Token] -> [Located Token]
loop Bool
False Bool
True                             [Block]
stack'  [Located Token]
ts

    -- We don't do layout within these delimeters
    | Sym TokenSym
ParenL   <- TokenT
ty = [Located Token]
toks [Located Token] -> [Located Token] -> [Located Token]
forall a. [a] -> [a] -> [a]
++ Bool -> Bool -> [Block] -> [Located Token] -> [Located Token]
loop Bool
False Bool
False (TokenT -> Block
Explicit (TokenSym -> TokenT
Sym TokenSym
ParenR)   Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
stack') [Located Token]
ts
    | Sym TokenSym
CurlyL   <- TokenT
ty = [Located Token]
toks [Located Token] -> [Located Token] -> [Located Token]
forall a. [a] -> [a] -> [a]
++ Bool -> Bool -> [Block] -> [Located Token] -> [Located Token]
loop Bool
False Bool
False (TokenT -> Block
Explicit (TokenSym -> TokenT
Sym TokenSym
CurlyR)   Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
stack') [Located Token]
ts
    | Sym TokenSym
BracketL <- TokenT
ty = [Located Token]
toks [Located Token] -> [Located Token] -> [Located Token]
forall a. [a] -> [a] -> [a]
++ Bool -> Bool -> [Block] -> [Located Token] -> [Located Token]
loop Bool
False Bool
False (TokenT -> Block
Explicit (TokenSym -> TokenT
Sym TokenSym
BracketR) Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
stack') [Located Token]
ts

    | TokenT
EOF          <- TokenT
ty = [Located Token]
toks
    | White TokenW
DocStr <- TokenT
ty = [Located Token]
toks [Located Token] -> [Located Token] -> [Located Token]
forall a. [a] -> [a] -> [a]
++ Bool -> Bool -> [Block] -> [Located Token] -> [Located Token]
loop Bool
True  Bool
False                            [Block]
stack'  [Located Token]
ts
    | Bool
otherwise          = [Located Token]
toks [Located Token] -> [Located Token] -> [Located Token]
forall a. [a] -> [a] -> [a]
++ Bool -> Bool -> [Block] -> [Located Token] -> [Located Token]
loop Bool
False Bool
False                            [Block]
stack'  [Located Token]
ts

    where
    ty :: TokenT
ty  = Token -> TokenT
tokenType (Located Token -> Token
forall a. Located a -> a
thing Located Token
t)
    pos :: Range
pos = Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
t

    ([Located Token]
toks,[Block]
offStack)
      | Bool
afterDoc  = ([Located Token
t], [Block]
stack)
      | Bool
otherwise = [Located Token]
-> Located Token -> [Block] -> ([Located Token], [Block])
offsides [Located Token]
startToks Located Token
t [Block]
stack

    -- add any block start tokens, and push a level on the stack
    ([Located Token]
startToks,[Block]
stack')
      | Bool
startBlock Bool -> Bool -> Bool
&& TokenT
ty TokenT -> TokenT -> Bool
forall a. Eq a => a -> a -> Bool
== TokenT
EOF = ( [ Config -> Position -> TokenV -> Located Token
virt Config
cfg (Range -> Position
to Range
pos) TokenV
VCurlyR
                                    , Config -> Position -> TokenV -> Located Token
virt Config
cfg (Range -> Position
to Range
pos) TokenV
VCurlyL ]
                                  , [Block]
offStack )
      | Bool
startBlock = ( [ Config -> Position -> TokenV -> Located Token
virt Config
cfg (Range -> Position
to Range
pos) TokenV
VCurlyL ], Int -> Block
Virtual (Position -> Int
col (Range -> Position
from Range
pos)) Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
offStack )
      | Bool
otherwise  = ( [], [Block]
offStack )

  loop Bool
_ Bool
_ [Block]
_ [] = FilePath -> [FilePath] -> [Located Token]
forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"[Lexer] layout" [FilePath
"Missing EOF token"]


  offsides :: [Located Token] -> Located Token -> [Block] -> ([Located Token], [Block])
  offsides :: [Located Token]
-> Located Token -> [Block] -> ([Located Token], [Block])
offsides [Located Token]
startToks Located Token
t = [Located Token] -> [Block] -> ([Located Token], [Block])
go [Located Token]
startToks
    where
    go :: [Located Token] -> [Block] -> ([Located Token], [Block])
go [Located Token]
virts [Block]
stack = case [Block]
stack of

      -- delimit or close a layout block
      Virtual Int
c : [Block]
rest
          -- commas only close to an explicit marker, so if there is none, the
          -- comma doesn't close anything
        | TokenSym -> TokenT
Sym TokenSym
Comma TokenT -> TokenT -> Bool
forall a. Eq a => a -> a -> Bool
== TokenT
ty     ->
                         if (Block -> Bool) -> [Block] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Block -> Bool
isExplicit [Block]
rest
                            then [Located Token] -> [Block] -> ([Located Token], [Block])
go   (Config -> Position -> TokenV -> Located Token
virt Config
cfg (Range -> Position
to Range
pos) TokenV
VCurlyR Located Token -> [Located Token] -> [Located Token]
forall a. a -> [a] -> [a]
: [Located Token]
virts) [Block]
rest
                            else [Located Token] -> [Block] -> ([Located Token], [Block])
forall b. [Located Token] -> b -> ([Located Token], b)
done                              [Located Token]
virts  [Block]
stack

        | Bool
closingToken        -> [Located Token] -> [Block] -> ([Located Token], [Block])
go   (Config -> Position -> TokenV -> Located Token
virt Config
cfg (Range -> Position
to Range
pos) TokenV
VCurlyR Located Token -> [Located Token] -> [Located Token]
forall a. a -> [a] -> [a]
: [Located Token]
virts) [Block]
rest
        | Position -> Int
col (Range -> Position
from Range
pos) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
c -> [Located Token] -> [Block] -> ([Located Token], [Block])
forall b. [Located Token] -> b -> ([Located Token], b)
done (Config -> Position -> TokenV -> Located Token
virt Config
cfg (Range -> Position
to Range
pos) TokenV
VSemi   Located Token -> [Located Token] -> [Located Token]
forall a. a -> [a] -> [a]
: [Located Token]
virts) [Block]
stack
        | Position -> Int
col (Range -> Position
from Range
pos) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  Int
c -> [Located Token] -> [Block] -> ([Located Token], [Block])
go   (Config -> Position -> TokenV -> Located Token
virt Config
cfg (Range -> Position
to Range
pos) TokenV
VCurlyR Located Token -> [Located Token] -> [Located Token]
forall a. a -> [a] -> [a]
: [Located Token]
virts) [Block]
rest

      -- close an explicit block
      Explicit TokenT
close : [Block]
rest | TokenT
close     TokenT -> TokenT -> Bool
forall a. Eq a => a -> a -> Bool
== TokenT
ty -> [Located Token] -> [Block] -> ([Located Token], [Block])
forall b. [Located Token] -> b -> ([Located Token], b)
done [Located Token]
virts [Block]
rest
                            | TokenSym -> TokenT
Sym TokenSym
Comma TokenT -> TokenT -> Bool
forall a. Eq a => a -> a -> Bool
== TokenT
ty -> [Located Token] -> [Block] -> ([Located Token], [Block])
forall b. [Located Token] -> b -> ([Located Token], b)
done [Located Token]
virts [Block]
stack

      [Block]
_ -> [Located Token] -> [Block] -> ([Located Token], [Block])
forall b. [Located Token] -> b -> ([Located Token], b)
done [Located Token]
virts [Block]
stack

    ty :: TokenT
ty  = Token -> TokenT
tokenType (Located Token -> Token
forall a. Located a -> a
thing Located Token
t)
    pos :: Range
pos = Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
t

    done :: [Located Token] -> b -> ([Located Token], b)
done [Located Token]
ts b
s = ([Located Token] -> [Located Token]
forall a. [a] -> [a]
reverse (Located Token
tLocated Token -> [Located Token] -> [Located Token]
forall a. a -> [a] -> [a]
:[Located Token]
ts), b
s)

    closingToken :: Bool
closingToken = TokenT
ty TokenT -> [TokenT] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ TokenSym -> TokenT
Sym TokenSym
ParenR, TokenSym -> TokenT
Sym TokenSym
BracketR, TokenSym -> TokenT
Sym TokenSym
CurlyR ]

virt :: Config -> Position -> TokenV -> Located Token
virt :: Config -> Position -> TokenV -> Located Token
virt Config
cfg Position
pos TokenV
x = Located :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range :: Position -> Position -> FilePath -> Range
Range
                             { from :: Position
from = Position
pos
                             , to :: Position
to = Position
pos
                             , source :: FilePath
source = Config -> FilePath
cfgSource Config
cfg
                             }
                         , thing :: Token
thing = Token
t }
  where t :: Token
t = TokenT -> Text -> Token
Token (TokenV -> TokenT
Virt TokenV
x) (Text -> Token) -> Text -> Token
forall a b. (a -> b) -> a -> b
$ case TokenV
x of
                               TokenV
VCurlyL -> Text
"beginning of layout block"
                               TokenV
VCurlyR -> Text
"end of layout block"
                               TokenV
VSemi   -> Text
"layout block separator"

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

data Token    = Token { Token -> TokenT
tokenType :: !TokenT, Token -> Text
tokenText :: !Text }
                deriving (Int -> Token -> ShowS
[Token] -> ShowS
Token -> FilePath
(Int -> Token -> ShowS)
-> (Token -> FilePath) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> FilePath
$cshow :: Token -> FilePath
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show, (forall x. Token -> Rep Token x)
-> (forall x. Rep Token x -> Token) -> Generic Token
forall x. Rep Token x -> Token
forall x. Token -> Rep Token x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Token x -> Token
$cfrom :: forall x. Token -> Rep Token x
Generic, Token -> ()
(Token -> ()) -> NFData Token
forall a. (a -> ()) -> NFData a
rnf :: Token -> ()
$crnf :: Token -> ()
NFData)

-- | Virtual tokens, inserted by layout processing.
data TokenV   = VCurlyL| VCurlyR | VSemi
                deriving (TokenV -> TokenV -> Bool
(TokenV -> TokenV -> Bool)
-> (TokenV -> TokenV -> Bool) -> Eq TokenV
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TokenV -> TokenV -> Bool
$c/= :: TokenV -> TokenV -> Bool
== :: TokenV -> TokenV -> Bool
$c== :: TokenV -> TokenV -> Bool
Eq, Int -> TokenV -> ShowS
[TokenV] -> ShowS
TokenV -> FilePath
(Int -> TokenV -> ShowS)
-> (TokenV -> FilePath) -> ([TokenV] -> ShowS) -> Show TokenV
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TokenV] -> ShowS
$cshowList :: [TokenV] -> ShowS
show :: TokenV -> FilePath
$cshow :: TokenV -> FilePath
showsPrec :: Int -> TokenV -> ShowS
$cshowsPrec :: Int -> TokenV -> ShowS
Show, (forall x. TokenV -> Rep TokenV x)
-> (forall x. Rep TokenV x -> TokenV) -> Generic TokenV
forall x. Rep TokenV x -> TokenV
forall x. TokenV -> Rep TokenV x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TokenV x -> TokenV
$cfrom :: forall x. TokenV -> Rep TokenV x
Generic, TokenV -> ()
(TokenV -> ()) -> NFData TokenV
forall a. (a -> ()) -> NFData a
rnf :: TokenV -> ()
$crnf :: TokenV -> ()
NFData)

data TokenW   = BlockComment | LineComment | Space | DocStr
                deriving (TokenW -> TokenW -> Bool
(TokenW -> TokenW -> Bool)
-> (TokenW -> TokenW -> Bool) -> Eq TokenW
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TokenW -> TokenW -> Bool
$c/= :: TokenW -> TokenW -> Bool
== :: TokenW -> TokenW -> Bool
$c== :: TokenW -> TokenW -> Bool
Eq, Int -> TokenW -> ShowS
[TokenW] -> ShowS
TokenW -> FilePath
(Int -> TokenW -> ShowS)
-> (TokenW -> FilePath) -> ([TokenW] -> ShowS) -> Show TokenW
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TokenW] -> ShowS
$cshowList :: [TokenW] -> ShowS
show :: TokenW -> FilePath
$cshow :: TokenW -> FilePath
showsPrec :: Int -> TokenW -> ShowS
$cshowsPrec :: Int -> TokenW -> ShowS
Show, (forall x. TokenW -> Rep TokenW x)
-> (forall x. Rep TokenW x -> TokenW) -> Generic TokenW
forall x. Rep TokenW x -> TokenW
forall x. TokenW -> Rep TokenW x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TokenW x -> TokenW
$cfrom :: forall x. TokenW -> Rep TokenW x
Generic, TokenW -> ()
(TokenW -> ()) -> NFData TokenW
forall a. (a -> ()) -> NFData a
rnf :: TokenW -> ()
$crnf :: TokenW -> ()
NFData)

data TokenKW  = KW_else
              | KW_extern
              | KW_fin
              | KW_if
              | KW_private
              | KW_include
              | KW_inf
              | KW_lg2
              | KW_lengthFromThen
              | KW_lengthFromThenTo
              | KW_max
              | KW_min
              | KW_module
              | KW_newtype
              | KW_pragma
              | KW_property
              | KW_then
              | KW_type
              | KW_where
              | KW_let
              | KW_x
              | KW_import
              | KW_as
              | KW_hiding
              | KW_infixl
              | KW_infixr
              | KW_infix
              | KW_primitive
              | KW_parameter
              | KW_constraint
              | KW_Prop
                deriving (TokenKW -> TokenKW -> Bool
(TokenKW -> TokenKW -> Bool)
-> (TokenKW -> TokenKW -> Bool) -> Eq TokenKW
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TokenKW -> TokenKW -> Bool
$c/= :: TokenKW -> TokenKW -> Bool
== :: TokenKW -> TokenKW -> Bool
$c== :: TokenKW -> TokenKW -> Bool
Eq, Int -> TokenKW -> ShowS
[TokenKW] -> ShowS
TokenKW -> FilePath
(Int -> TokenKW -> ShowS)
-> (TokenKW -> FilePath) -> ([TokenKW] -> ShowS) -> Show TokenKW
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TokenKW] -> ShowS
$cshowList :: [TokenKW] -> ShowS
show :: TokenKW -> FilePath
$cshow :: TokenKW -> FilePath
showsPrec :: Int -> TokenKW -> ShowS
$cshowsPrec :: Int -> TokenKW -> ShowS
Show, (forall x. TokenKW -> Rep TokenKW x)
-> (forall x. Rep TokenKW x -> TokenKW) -> Generic TokenKW
forall x. Rep TokenKW x -> TokenKW
forall x. TokenKW -> Rep TokenKW x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TokenKW x -> TokenKW
$cfrom :: forall x. TokenKW -> Rep TokenKW x
Generic, TokenKW -> ()
(TokenKW -> ()) -> NFData TokenKW
forall a. (a -> ()) -> NFData a
rnf :: TokenKW -> ()
$crnf :: TokenKW -> ()
NFData)

-- | The named operators are a special case for parsing types, and 'Other' is
-- used for all other cases that lexed as an operator.
data TokenOp  = Plus | Minus | Mul | Div | Exp | Mod
              | Equal | LEQ | GEQ
              | Complement | Hash | At
              | Other [T.Text] T.Text
                deriving (TokenOp -> TokenOp -> Bool
(TokenOp -> TokenOp -> Bool)
-> (TokenOp -> TokenOp -> Bool) -> Eq TokenOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TokenOp -> TokenOp -> Bool
$c/= :: TokenOp -> TokenOp -> Bool
== :: TokenOp -> TokenOp -> Bool
$c== :: TokenOp -> TokenOp -> Bool
Eq, Int -> TokenOp -> ShowS
[TokenOp] -> ShowS
TokenOp -> FilePath
(Int -> TokenOp -> ShowS)
-> (TokenOp -> FilePath) -> ([TokenOp] -> ShowS) -> Show TokenOp
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TokenOp] -> ShowS
$cshowList :: [TokenOp] -> ShowS
show :: TokenOp -> FilePath
$cshow :: TokenOp -> FilePath
showsPrec :: Int -> TokenOp -> ShowS
$cshowsPrec :: Int -> TokenOp -> ShowS
Show, (forall x. TokenOp -> Rep TokenOp x)
-> (forall x. Rep TokenOp x -> TokenOp) -> Generic TokenOp
forall x. Rep TokenOp x -> TokenOp
forall x. TokenOp -> Rep TokenOp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TokenOp x -> TokenOp
$cfrom :: forall x. TokenOp -> Rep TokenOp x
Generic, TokenOp -> ()
(TokenOp -> ()) -> NFData TokenOp
forall a. (a -> ()) -> NFData a
rnf :: TokenOp -> ()
$crnf :: TokenOp -> ()
NFData)

data TokenSym = Bar
              | ArrL | ArrR | FatArrR
              | Lambda
              | EqDef
              | Comma
              | Semi
              | Dot
              | DotDot
              | DotDotDot
              | DotDotLt
              | Colon
              | BackTick
              | ParenL   | ParenR
              | BracketL | BracketR
              | CurlyL   | CurlyR
              | TriL     | TriR
              | Lt
              | Underscore
                deriving (TokenSym -> TokenSym -> Bool
(TokenSym -> TokenSym -> Bool)
-> (TokenSym -> TokenSym -> Bool) -> Eq TokenSym
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TokenSym -> TokenSym -> Bool
$c/= :: TokenSym -> TokenSym -> Bool
== :: TokenSym -> TokenSym -> Bool
$c== :: TokenSym -> TokenSym -> Bool
Eq, Int -> TokenSym -> ShowS
[TokenSym] -> ShowS
TokenSym -> FilePath
(Int -> TokenSym -> ShowS)
-> (TokenSym -> FilePath) -> ([TokenSym] -> ShowS) -> Show TokenSym
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TokenSym] -> ShowS
$cshowList :: [TokenSym] -> ShowS
show :: TokenSym -> FilePath
$cshow :: TokenSym -> FilePath
showsPrec :: Int -> TokenSym -> ShowS
$cshowsPrec :: Int -> TokenSym -> ShowS
Show, (forall x. TokenSym -> Rep TokenSym x)
-> (forall x. Rep TokenSym x -> TokenSym) -> Generic TokenSym
forall x. Rep TokenSym x -> TokenSym
forall x. TokenSym -> Rep TokenSym x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TokenSym x -> TokenSym
$cfrom :: forall x. TokenSym -> Rep TokenSym x
Generic, TokenSym -> ()
(TokenSym -> ()) -> NFData TokenSym
forall a. (a -> ()) -> NFData a
rnf :: TokenSym -> ()
$crnf :: TokenSym -> ()
NFData)

data TokenErr = UnterminatedComment
              | UnterminatedString
              | UnterminatedChar
              | InvalidString
              | InvalidChar
              | LexicalError
              | MalformedLiteral
              | MalformedSelector
                deriving (TokenErr -> TokenErr -> Bool
(TokenErr -> TokenErr -> Bool)
-> (TokenErr -> TokenErr -> Bool) -> Eq TokenErr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TokenErr -> TokenErr -> Bool
$c/= :: TokenErr -> TokenErr -> Bool
== :: TokenErr -> TokenErr -> Bool
$c== :: TokenErr -> TokenErr -> Bool
Eq, Int -> TokenErr -> ShowS
[TokenErr] -> ShowS
TokenErr -> FilePath
(Int -> TokenErr -> ShowS)
-> (TokenErr -> FilePath) -> ([TokenErr] -> ShowS) -> Show TokenErr
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TokenErr] -> ShowS
$cshowList :: [TokenErr] -> ShowS
show :: TokenErr -> FilePath
$cshow :: TokenErr -> FilePath
showsPrec :: Int -> TokenErr -> ShowS
$cshowsPrec :: Int -> TokenErr -> ShowS
Show, (forall x. TokenErr -> Rep TokenErr x)
-> (forall x. Rep TokenErr x -> TokenErr) -> Generic TokenErr
forall x. Rep TokenErr x -> TokenErr
forall x. TokenErr -> Rep TokenErr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TokenErr x -> TokenErr
$cfrom :: forall x. TokenErr -> Rep TokenErr x
Generic, TokenErr -> ()
(TokenErr -> ()) -> NFData TokenErr
forall a. (a -> ()) -> NFData a
rnf :: TokenErr -> ()
$crnf :: TokenErr -> ()
NFData)

data SelectorType = RecordSelectorTok Text | TupleSelectorTok Int
                deriving (SelectorType -> SelectorType -> Bool
(SelectorType -> SelectorType -> Bool)
-> (SelectorType -> SelectorType -> Bool) -> Eq SelectorType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SelectorType -> SelectorType -> Bool
$c/= :: SelectorType -> SelectorType -> Bool
== :: SelectorType -> SelectorType -> Bool
$c== :: SelectorType -> SelectorType -> Bool
Eq, Int -> SelectorType -> ShowS
[SelectorType] -> ShowS
SelectorType -> FilePath
(Int -> SelectorType -> ShowS)
-> (SelectorType -> FilePath)
-> ([SelectorType] -> ShowS)
-> Show SelectorType
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [SelectorType] -> ShowS
$cshowList :: [SelectorType] -> ShowS
show :: SelectorType -> FilePath
$cshow :: SelectorType -> FilePath
showsPrec :: Int -> SelectorType -> ShowS
$cshowsPrec :: Int -> SelectorType -> ShowS
Show, (forall x. SelectorType -> Rep SelectorType x)
-> (forall x. Rep SelectorType x -> SelectorType)
-> Generic SelectorType
forall x. Rep SelectorType x -> SelectorType
forall x. SelectorType -> Rep SelectorType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SelectorType x -> SelectorType
$cfrom :: forall x. SelectorType -> Rep SelectorType x
Generic, SelectorType -> ()
(SelectorType -> ()) -> NFData SelectorType
forall a. (a -> ()) -> NFData a
rnf :: SelectorType -> ()
$crnf :: SelectorType -> ()
NFData)

data TokenT   = Num !Integer !Int !Int   -- ^ value, base, number of digits
              | Frac !Rational !Int      -- ^ value, base.
              | ChrLit  !Char         -- ^ character literal
              | Ident ![T.Text] !T.Text -- ^ (qualified) identifier
              | StrLit !String         -- ^ string literal
              | Selector !SelectorType  -- ^ .hello or .123
              | KW    !TokenKW         -- ^ keyword
              | Op    !TokenOp         -- ^ operator
              | Sym   !TokenSym        -- ^ symbol
              | Virt  !TokenV          -- ^ virtual token (for layout)
              | White !TokenW          -- ^ white space token
              | Err   !TokenErr        -- ^ error token
              | EOF
                deriving (TokenT -> TokenT -> Bool
(TokenT -> TokenT -> Bool)
-> (TokenT -> TokenT -> Bool) -> Eq TokenT
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TokenT -> TokenT -> Bool
$c/= :: TokenT -> TokenT -> Bool
== :: TokenT -> TokenT -> Bool
$c== :: TokenT -> TokenT -> Bool
Eq, Int -> TokenT -> ShowS
[TokenT] -> ShowS
TokenT -> FilePath
(Int -> TokenT -> ShowS)
-> (TokenT -> FilePath) -> ([TokenT] -> ShowS) -> Show TokenT
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TokenT] -> ShowS
$cshowList :: [TokenT] -> ShowS
show :: TokenT -> FilePath
$cshow :: TokenT -> FilePath
showsPrec :: Int -> TokenT -> ShowS
$cshowsPrec :: Int -> TokenT -> ShowS
Show, (forall x. TokenT -> Rep TokenT x)
-> (forall x. Rep TokenT x -> TokenT) -> Generic TokenT
forall x. Rep TokenT x -> TokenT
forall x. TokenT -> Rep TokenT x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TokenT x -> TokenT
$cfrom :: forall x. TokenT -> Rep TokenT x
Generic, TokenT -> ()
(TokenT -> ()) -> NFData TokenT
forall a. (a -> ()) -> NFData a
rnf :: TokenT -> ()
$crnf :: TokenT -> ()
NFData)

instance PP Token where
  ppPrec :: Int -> Token -> Doc
ppPrec Int
_ (Token TokenT
_ Text
s) = FilePath -> Doc
text (Text -> FilePath
T.unpack Text
s)

-- | 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