{-# LANGUAGE RecordWildCards, BangPatterns #-}

-- Most of this module follows the Haskell report, https://www.haskell.org/onlinereport/lexemes.html
module Lexer(Lexeme(..), lexer, unlexerFile) where

import Data.Char
import Data.List.Extra
import Data.Tuple.Extra

-- | A lexeme of text, approx some letters followed by some space.
data Lexeme = Lexeme
    {Lexeme -> Int
line :: {-# UNPACK #-} !Int -- ^ 1-based line number (0 = generated)
    ,Lexeme -> Int
col :: {-# UNPACK #-} !Int -- ^ 1-based col number (0 = generated)
    ,Lexeme -> String
lexeme :: String -- ^ Actual text of the item
    ,Lexeme -> String
whitespace :: String -- ^ Suffix spaces and comments
    } deriving Int -> Lexeme -> ShowS
[Lexeme] -> ShowS
Lexeme -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Lexeme] -> ShowS
$cshowList :: [Lexeme] -> ShowS
show :: Lexeme -> String
$cshow :: Lexeme -> String
showsPrec :: Int -> Lexeme -> ShowS
$cshowsPrec :: Int -> Lexeme -> ShowS
Show


charNewline :: Char -> Bool
charNewline Char
x = Char
x forall a. Eq a => a -> a -> Bool
== Char
'\r' Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'\n' Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'\f'
charSpecial :: Char -> Bool
charSpecial Char
x = Char
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"(),;[]`{}"
charAscSymbol :: Char -> Bool
charAscSymbol Char
x = Char
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"!#$%&*+./<=>?@\\^|-~" Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
':' -- special case for me
charSymbol :: Char -> Bool
charSymbol Char
x = Char -> Bool
charAscSymbol Char
x Bool -> Bool -> Bool
|| (Char -> Bool
isSymbol Char
x Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
charSpecial Char
x) Bool -> Bool -> Bool
&& Char
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
"_\"\'")

charIdentStart :: Char -> Bool
charIdentStart Char
x = Char -> Bool
isAlpha Char
x Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'_'
charIdentCont :: Char -> Bool
charIdentCont Char
x = Char -> Bool
isAlphaNum Char
x Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'\''


lexer :: String -> [Lexeme]
lexer :: String -> [Lexeme]
lexer = Int -> Int -> String -> [Lexeme]
go1 Int
1 Int
1
    where
        -- we might start with whitespace, before any lexemes
        go1 :: Int -> Int -> String -> [Lexeme]
go1 Int
line Int
col String
xs
            | (String
whitespace, String
xs) <- String -> (String, String)
lexerWhitespace String
xs
            , String
whitespace forall a. Eq a => a -> a -> Bool
/= String
""
            , (Int
line2, Int
col2) <- Int -> Int -> String -> (Int, Int)
reposition Int
line Int
col String
whitespace
            = Lexeme{lexeme :: String
lexeme=String
"", Int
String
whitespace :: String
col :: Int
line :: Int
whitespace :: String
col :: Int
line :: Int
..} forall a. a -> [a] -> [a]
: Int -> Int -> String -> [Lexeme]
go Int
line2 Int
col2 String
xs
        go1 Int
line Int
col String
xs = Int -> Int -> String -> [Lexeme]
go Int
line Int
col String
xs

        go :: Int -> Int -> String -> [Lexeme]
go Int
line Int
col String
"" = []
        go Int
line Int
col String
xs
            | (String
lexeme, String
xs) <- String -> (String, String)
lexerLexeme String
xs
            , (String
whitespace, String
xs) <- String -> (String, String)
lexerWhitespace String
xs
            , (Int
line2, Int
col2) <- Int -> Int -> String -> (Int, Int)
reposition Int
line Int
col forall a b. (a -> b) -> a -> b
$ String
lexeme forall a. [a] -> [a] -> [a]
++ String
whitespace
            = Lexeme{Int
String
whitespace :: String
lexeme :: String
col :: Int
line :: Int
whitespace :: String
lexeme :: String
col :: Int
line :: Int
..} forall a. a -> [a] -> [a]
: Int -> Int -> String -> [Lexeme]
go Int
line2 Int
col2 String
xs


reposition :: Int -> Int -> String -> (Int, Int)
reposition :: Int -> Int -> String -> (Int, Int)
reposition = forall {t} {t}. (Num t, Num t) => t -> t -> String -> (t, t)
go
    where
        go :: t -> t -> String -> (t, t)
go !t
line !t
col [] = (t
line, t
col)
        go t
line t
col (Char
x:String
xs)
            | Char
x forall a. Eq a => a -> a -> Bool
== Char
'\n' = t -> t -> String -> (t, t)
go (t
lineforall a. Num a => a -> a -> a
+t
1) t
1 String
xs
            | Char
x forall a. Eq a => a -> a -> Bool
== Char
'\t' = t -> t -> String -> (t, t)
go t
line (t
colforall a. Num a => a -> a -> a
+t
8) String
xs -- technically not totally correct, but please, don't use tabs
            | Bool
otherwise = t -> t -> String -> (t, t)
go t
line (t
colforall a. Num a => a -> a -> a
+t
1) String
xs


-- We take a lot of liberties with lexemes around module qualification, because we want to make fields magic
-- we ignore numbers entirely because they don't have any impact on what we want to do
lexerLexeme :: String -> (String, String)
lexerLexeme :: String -> (String, String)
lexerLexeme (Char
'\'':Char
x:Char
'\'':String
xs) = ([Char
'\'',Char
x,Char
'\''], String
xs)
lexerLexeme (Char
'\'':Char
x:String
xs) | Char
x forall a. Eq a => a -> a -> Bool
/= Char
'\'' = (String
"\'", Char
xforall a. a -> [a] -> [a]
:String
xs) -- might be a data kind, see #25
lexerLexeme (Char
open:String
xs) | Char
open forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char
open forall a. Eq a => a -> a -> Bool
== Char
'\"' = forall {a} {b}. [a] -> ([a], b) -> ([a], b)
seen [Char
open] forall a b. (a -> b) -> a -> b
$ String -> (String, String)
go String
xs
    where
        go :: String -> (String, String)
go (Char
x:String
xs) | Char
x forall a. Eq a => a -> a -> Bool
== Char
open = ([Char
x], String
xs)
                  | Char
x forall a. Eq a => a -> a -> Bool
== Char
'\\', Char
x2:String
xs <- String
xs = forall {a} {b}. [a] -> ([a], b) -> ([a], b)
seen [Char
x,Char
x2] forall a b. (a -> b) -> a -> b
$ String -> (String, String)
go String
xs
                  | Bool
otherwise = forall {a} {b}. [a] -> ([a], b) -> ([a], b)
seen [Char
x] forall a b. (a -> b) -> a -> b
$ String -> (String, String)
go String
xs
        go [] = ([], [])
lexerLexeme (Char
x:String
xs)
    | Char -> Bool
charSymbol Char
x
    , (String
a, String
xs) <- forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
charSymbol String
xs
    = (Char
xforall a. a -> [a] -> [a]
:String
a, String
xs)
lexerLexeme (Char
x:String
xs)
    | Char -> Bool
charIdentStart Char
x
    , (String
a, String
xs) <- forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
charIdentCont String
xs
    = (Char
xforall a. a -> [a] -> [a]
:String
a, String
xs)
lexerLexeme (Char
x:String
xs) = ([Char
x], String
xs)
lexerLexeme [] = ([], [])


lexerWhitespace :: String -> (String, String)
lexerWhitespace :: String -> (String, String)
lexerWhitespace (Char
x:String
xs) | Char -> Bool
isSpace Char
x = forall {a} {b}. [a] -> ([a], b) -> ([a], b)
seen [Char
x] forall a b. (a -> b) -> a -> b
$ String -> (String, String)
lexerWhitespace String
xs
lexerWhitespace (Char
'-':Char
'-':String
xs)
    | (String
a, String
xs) <- forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
== Char
'-') String
xs
    , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
charSymbol forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
1 String
xs
    , (String
b, String
xs) <- forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
charNewline String
xs
    , (String
c, String
xs) <- forall a. Int -> [a] -> ([a], [a])
splitAt Int
1 String
xs
    = forall {a} {b}. [a] -> ([a], b) -> ([a], b)
seen String
"--" forall a b. (a -> b) -> a -> b
$ forall {a} {b}. [a] -> ([a], b) -> ([a], b)
seen String
a forall a b. (a -> b) -> a -> b
$ forall {a} {b}. [a] -> ([a], b) -> ([a], b)
seen String
b forall a b. (a -> b) -> a -> b
$ forall {a} {b}. [a] -> ([a], b) -> ([a], b)
seen String
c forall a b. (a -> b) -> a -> b
$ String -> (String, String)
lexerWhitespace String
xs
lexerWhitespace (Char
'{':Char
'-':String
xs) = forall {a} {b}. [a] -> ([a], b) -> ([a], b)
seen String
"{-" forall a b. (a -> b) -> a -> b
$ forall {t}. (Eq t, Num t) => t -> String -> (String, String)
f Integer
1 String
xs
    where
        f :: t -> String -> (String, String)
f t
1 (Char
'-':Char
'}':String
xs) = forall {a} {b}. [a] -> ([a], b) -> ([a], b)
seen String
"-}" forall a b. (a -> b) -> a -> b
$ String -> (String, String)
lexerWhitespace String
xs
        f t
i (Char
'-':Char
'}':String
xs) = forall {a} {b}. [a] -> ([a], b) -> ([a], b)
seen String
"-}" forall a b. (a -> b) -> a -> b
$ t -> String -> (String, String)
f (t
iforall a. Num a => a -> a -> a
-t
1) String
xs
        f t
i (Char
'{':Char
'-':String
xs) = forall {a} {b}. [a] -> ([a], b) -> ([a], b)
seen String
"{-" forall a b. (a -> b) -> a -> b
$ t -> String -> (String, String)
f (t
iforall a. Num a => a -> a -> a
+t
1) String
xs
        f t
i (Char
x:String
xs) = forall {a} {b}. [a] -> ([a], b) -> ([a], b)
seen [Char
x] forall a b. (a -> b) -> a -> b
$ t -> String -> (String, String)
f t
i String
xs
        f t
i [] = ([], [])
lexerWhitespace String
xs = ([], String
xs)

seen :: [a] -> ([a], b) -> ([a], b)
seen [a]
xs = forall a a' b. (a -> a') -> (a, b) -> (a', b)
first ([a]
xsforall a. [a] -> [a] -> [a]
++)


unlexerFile :: Maybe FilePath -> [Lexeme] -> String
unlexerFile :: Maybe String -> [Lexeme] -> String
unlexerFile Maybe String
src [Lexeme]
xs =
    forall {a}. Show a => a -> String
dropping Integer
1 forall a. [a] -> [a] -> [a]
++
    -- we split the whitespace up to increase the chances of startLine being true below
    -- pretty ugly code...
    Int -> Bool -> [(Int, String)] -> String
go Int
1 Bool
True (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [(Int
line, String
lexeme forall a. [a] -> [a] -> [a]
++ String
w1 forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
take Int
1 String
w2)
          ,(if Int
line forall a. Eq a => a -> a -> Bool
== Int
0 then Int
0 else Int
line forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
== Char
'\n') (String
lexeme forall a. [a] -> [a] -> [a]
++ String
w1 forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
take Int
1 String
w2)), forall a. [a] -> [a]
drop1 String
w2)]
        | Lexeme{Int
String
whitespace :: String
col :: Int
lexeme :: String
line :: Int
whitespace :: Lexeme -> String
lexeme :: Lexeme -> String
col :: Lexeme -> Int
line :: Lexeme -> Int
..} <- [Lexeme]
xs, let (String
w1,String
w2) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'\n') String
whitespace])
    where
        go
            :: Int -- ^ What line does GHC think we are on
            -> Bool -- ^ Are we at the start of a line
            -> [(Int, String)] -- ^ (original line, lexemes followed by their whitespace)
            -> String
        go :: Int -> Bool -> [(Int, String)] -> String
go Int
ghcLine Bool
startLine ((Int
i, String
x):[(Int, String)]
xs) =
            (if Bool
emitDropping then forall {a}. Show a => a -> String
dropping Int
i else String
"") forall a. [a] -> [a] -> [a]
++
            String
x forall a. [a] -> [a] -> [a]
++
            Int -> Bool -> [(Int, String)] -> String
go
                ((if Bool
emitDropping then Int
i else Int
ghcLine) forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
== Char
'\n') String
x))
                (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x then Bool
startLine else String
"\n" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
x)
                [(Int, String)]
xs
            where emitDropping :: Bool
emitDropping = Int
ghcLine forall a. Eq a => a -> a -> Bool
/= Int
i Bool -> Bool -> Bool
&& Int
i forall a. Eq a => a -> a -> Bool
/= Int
0 Bool -> Bool -> Bool
&& Bool
startLine
        go Int
_ Bool
_ [] = String
""

        -- write out a line marker with a trailing newline
        dropping :: a -> String
dropping a
n = case Maybe String
src of
          Just String
src' -> String
"{-# LINE " forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => a -> String
show a
n forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => a -> String
show String
src' forall a. [a] -> [a] -> [a]
++ String
" #-}\n"
          Maybe String
Nothing -> String
""