{-# LANGUAGE MagicHash, UnboxedTuples, FlexibleInstances #-}
module Scanner where
import GHC.Prim
import TokenDef
import UU.Scanner.Position
import UU.Scanner.Token
import UU.Parsing(InputState(..),Either'(..))
import Data.Maybe
import Data.List
import Data.Char
import UU.Scanner.GenToken
import Options (Options (..))

data Input = Input !Pos String (Maybe (Token, Input))

instance InputState Input Token Pos where
 splitStateE :: Input -> Either' Input Token
splitStateE input :: Input
input@(Input Pos
_ String
_ Maybe (Token, Input)
next) =
                case Maybe (Token, Input)
next of
                     Maybe (Token, Input)
Nothing         -> Input -> Either' Input Token
forall state s. state -> Either' state s
Right' Input
input
                     Just (Token
s, Input
rest)  -> Token -> Input -> Either' Input Token
forall state s. s -> state -> Either' state s
Left' Token
s Input
rest
 splitState :: Input -> (# Token, Input #)
splitState (Input Pos
_ String
_ Maybe (Token, Input)
next) =
                case Maybe (Token, Input)
next of
                     Maybe (Token, Input)
Nothing         -> String -> (# Token, Input #)
forall a. HasCallStack => String -> a
error String
"splitState on empty input"
                     Just (Token
s, Input
rest)  -> (# Token
s, Input
rest #)
 getPosition :: Input -> Pos
getPosition (Input Pos
pos String
_ Maybe (Token, Input)
next) =  case Maybe (Token, Input)
next of
                                    Just (Token
s,Input
_) -> Token -> Pos
forall k t v. GenToken k t v -> Pos
position Token
s
                                    Maybe (Token, Input)
Nothing    -> Pos
pos -- end of file



input :: Options -> Pos -> String -> Input
input :: Options -> Pos -> String -> Input
input Options
opts Pos
pos String
inp = Pos -> String -> Maybe (Token, Input) -> Input
Input Pos
pos
                      String
inp
                      (case Options -> Lexer Token
scan Options
opts Pos
pos String
inp of
                             Maybe (Token, Pos, String)
Nothing      -> Maybe (Token, Input)
forall a. Maybe a
Nothing
                             Just (Token
s,Pos
p,String
r) -> (Token, Input) -> Maybe (Token, Input)
forall a. a -> Maybe a
Just (Token
s, Options -> Pos -> String -> Input
input Options
opts Pos
p String
r)
                      )

type Lexer s = Pos -> String -> Maybe (s,Pos,String)

scan :: Options -> Lexer Token
scan :: Options -> Lexer Token
scan Options
opts Pos
p0
  | Pos -> Column
forall p. Position p => p -> Column
column Pos
p0 Column -> Column -> Bool
forall a. Eq a => a -> a -> Bool
== Column
1 = Lexer Token
scanBeginOfLine Pos
p0
  | Bool
otherwise      = Lexer Token
scan Pos
p0
  where
    keywords' :: [String]
keywords' = if Options -> Bool
lcKeywords Options
opts
                then (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) [String]
keywords
                else [String]
keywords
    mkKeyword :: String -> String
mkKeyword String
s | String
s String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
lowercaseKeywords = String
s
                | Bool
otherwise                  = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
s

    scan :: Lexer Token
    scan :: Lexer Token
scan Pos
p []                        = Maybe (Token, Pos, String)
forall a. Maybe a
Nothing
    scan Pos
p (Char
'/':Char
'/':String
xs)
      | Options -> Bool
clean Options
opts
                                     = let (String
com,String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') String
xs
                                       in Column
-> Pos -> Lexer Token -> String -> Maybe (Token, Pos, String)
forall a. Column -> Pos -> (Pos -> a) -> a
advc' (Column
2Column -> Column -> Column
forall a. Num a => a -> a -> a
+String -> Column
forall (t :: * -> *) a. Foldable t => t a -> Column
length String
com) Pos
p Lexer Token
scan String
rest
    scan Pos
p (Char
'-':Char
'-':String
xs) | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
xs Bool -> Bool -> Bool
|| Bool -> Bool
not (String -> Char
forall a. [a] -> a
head String
xs Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"<>!?#@:%$^&")
                                     = let (String
com,String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') String
xs
                                       in Column
-> Pos -> Lexer Token -> String -> Maybe (Token, Pos, String)
forall a. Column -> Pos -> (Pos -> a) -> a
advc' (Column
2Column -> Column -> Column
forall a. Num a => a -> a -> a
+String -> Column
forall (t :: * -> *) a. Foldable t => t a -> Column
length String
com) Pos
p Lexer Token
scan String
rest
    scan Pos
p (Char
'{':Char
'-':String
xs)              = Column
-> Pos -> Lexer Token -> String -> Maybe (Token, Pos, String)
forall a. Column -> Pos -> (Pos -> a) -> a
advc' Column
2 Pos
p (Lexer Token -> Lexer Token
forall a.
(Pos -> String -> Maybe (Token, Pos, [a]))
-> Pos -> String -> Maybe (Token, Pos, [a])
ncomment Lexer Token
scan) String
xs
    scan Pos
p (Char
'/':Char
'*':String
xs) | Options -> Bool
clean Options
opts = Column
-> Pos -> Lexer Token -> String -> Maybe (Token, Pos, String)
forall a. Column -> Pos -> (Pos -> a) -> a
advc' Column
2 Pos
p (Lexer Token -> Lexer Token
forall a.
(Pos -> String -> Maybe (Token, Pos, [a]))
-> Pos -> String -> Maybe (Token, Pos, [a])
cleancomment Lexer Token
scan) String
xs
    scan Pos
p (Char
'{'    :String
xs)              = Column
-> Pos -> Lexer Token -> String -> Maybe (Token, Pos, String)
forall a. Column -> Pos -> (Pos -> a) -> a
advc' Column
1 Pos
p Lexer Token
codescrap String
xs
    scan Pos
p (Char
'\CR':String
xs)                = case String
xs of
                                        Char
'\LF':String
ys -> Pos -> Lexer Token -> String -> Maybe (Token, Pos, String)
forall a. Pos -> (Pos -> a) -> a
newl' Pos
p Lexer Token
scanBeginOfLine String
ys --ms newline

                                        String
_        -> Pos -> Lexer Token -> String -> Maybe (Token, Pos, String)
forall a. Pos -> (Pos -> a) -> a
newl' Pos
p Lexer Token
scanBeginOfLine String
xs --mac newline

    scan Pos
p (Char
'\LF':String
xs)                =  Pos -> Lexer Token -> String -> Maybe (Token, Pos, String)
forall a. Pos -> (Pos -> a) -> a
newl' Pos
p Lexer Token
scanBeginOfLine String
xs             --unix newline

    scan Pos
p (Char
x:String
xs) | Char -> Bool
isSpace Char
x        = Char -> Pos -> Lexer Token -> String -> Maybe (Token, Pos, String)
forall a. Char -> Pos -> (Pos -> a) -> a
updPos'  Char
x Pos
p Lexer Token
scan  String
xs
    scan Pos
p String
xs = (Token, Pos, String) -> Maybe (Token, Pos, String)
forall a. a -> Maybe a
Just (String -> (Token, Pos, String)
scan' String
xs)
      where scan' :: String -> (Token, Pos, String)
scan' (Char
'.' :String
rs)          = (String -> Pos -> Token
reserved String
"." Pos
p, Column -> Pos -> Pos
advc Column
1 Pos
p, String
rs)
            scan' (Char
'@' :String
rs)          = (String -> Pos -> Token
reserved String
"@" Pos
p, Column -> Pos -> Pos
advc Column
1 Pos
p, String
rs)
            scan' (Char
',' :String
rs)          = (String -> Pos -> Token
reserved String
"," Pos
p, Column -> Pos -> Pos
advc Column
1 Pos
p, String
rs)
            scan' (Char
'_' :String
rs)          = (String -> Pos -> Token
reserved String
"_" Pos
p, Column -> Pos -> Pos
advc Column
1 Pos
p, String
rs)
            scan' (Char
'~' :String
rs)          = (String -> Pos -> Token
reserved String
"~" Pos
p, Column -> Pos -> Pos
advc Column
1 Pos
p, String
rs)
            scan' (Char
'+' :String
rs)          = (String -> Pos -> Token
reserved String
"+" Pos
p, Column -> Pos -> Pos
advc Column
1 Pos
p, String
rs)
            scan' (Char
'<' : Char
'-' : String
rs)   = (String -> Pos -> Token
reserved String
"<-" Pos
p, Column -> Pos -> Pos
advc Column
2 Pos
p, String
rs)
            scan' (Char
'<' : Char
'=' : String
rs)   = (String -> Pos -> Token
reserved String
"<=" Pos
p, Column -> Pos -> Pos
advc Column
2 Pos
p, String
rs)
            scan' (Char
'<' : Char
'<' : Char
'-' : String
rs) = (String -> Pos -> Token
reserved String
"<<-" Pos
p, Column -> Pos -> Pos
advc Column
3 Pos
p, String
rs)
            scan' (Char
'<' :String
rs)          = (String -> Pos -> Token
reserved String
"<" Pos
p, Column -> Pos -> Pos
advc Column
1 Pos
p, String
rs)
            scan' (Char
'[' :String
rs)          = (String -> Pos -> Token
reserved String
"[" Pos
p, Column -> Pos -> Pos
advc Column
1 Pos
p, String
rs)
            scan' (Char
']' :String
rs)          = (String -> Pos -> Token
reserved String
"]" Pos
p, Column -> Pos -> Pos
advc Column
1 Pos
p, String
rs)
            scan' (Char
'(' :String
rs)          = (String -> Pos -> Token
reserved String
"(" Pos
p, Column -> Pos -> Pos
advc Column
1 Pos
p, String
rs)
            scan' (Char
')' :String
rs)          = (String -> Pos -> Token
reserved String
")" Pos
p, Column -> Pos -> Pos
advc Column
1 Pos
p, String
rs)
    --        scan' ('{'    :rs)       = (OBrace      p, advc 1 p, rs)

    --        scan' ('}'    :rs)       = (CBrace      p, advc 1 p, rs)


            scan' (Char
'\"' :String
rs)         = let isOk :: Char -> Bool
isOk Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n'
                                           (String
str,String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isOk String
rs
                                       in if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rest Bool -> Bool -> Bool
|| String -> Char
forall a. [a] -> a
head String
rest Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"'
                                              then (String -> Pos -> Token
errToken String
"unterminated string literal"   Pos
p
                                                   , Column -> Pos -> Pos
advc (Column
1Column -> Column -> Column
forall a. Num a => a -> a -> a
+String -> Column
forall (t :: * -> *) a. Foldable t => t a -> Column
length String
str) Pos
p,String
rest)
                                              else (EnumValToken -> String -> Pos -> Token
valueToken EnumValToken
TkString String
str Pos
p, Column -> Pos -> Pos
advc (Column
2Column -> Column -> Column
forall a. Num a => a -> a -> a
+String -> Column
forall (t :: * -> *) a. Foldable t => t a -> Column
length String
str) Pos
p, String -> String
forall a. [a] -> [a]
tail String
rest)

            scan' (Char
'=' : Char
'>' : String
rs)   = (String -> Pos -> Token
reserved String
"=>" Pos
p, Column -> Pos -> Pos
advc Column
2 Pos
p, String
rs)
            scan' (Char
'=' :String
rs)          = (String -> Pos -> Token
reserved String
"=" Pos
p, Column -> Pos -> Pos
advc Column
1 Pos
p, String
rs)
            scan' (Char
':':Char
'=':String
rs)       = (String -> Pos -> Token
reserved String
":=" Pos
p, Column -> Pos -> Pos
advc Column
2 Pos
p, String
rs)
            scan' (Char
':':Char
':':String
rs)       = (String -> Pos -> Token
reserved String
"::" Pos
p, Column -> Pos -> Pos
advc Column
2 Pos
p, String
rs)
            scan' (Char
'∷':String
rs)           = (String -> Pos -> Token
reserved String
"::" Pos
p, Column -> Pos -> Pos
advc Column
1 Pos
p, String
rs)  -- recognize unicode double colons too

            scan' (Char
':' :String
rs)                           = (String -> Pos -> Token
reserved String
":" Pos
p, Column -> Pos -> Pos
advc Column
1 Pos
p, String
rs)
            scan' (Char
'|' :String
rs)          = (String -> Pos -> Token
reserved String
"|" Pos
p, Column -> Pos -> Pos
advc Column
1 Pos
p, String
rs)

            scan' (Char
'/':Char
'\\':String
rs)      = (String -> Pos -> Token
reserved String
"/\\" Pos
p, Column -> Pos -> Pos
advc Column
2 Pos
p, String
rs)
            scan' (Char
'-':Char
'>' :String
rs)      = (String -> Pos -> Token
reserved String
"->" Pos
p, Column -> Pos -> Pos
advc Column
2 Pos
p, String
rs)
            scan' (Char
'-'     :String
rs)      = (String -> Pos -> Token
reserved String
"-" Pos
p, Column -> Pos -> Pos
advc Column
1 Pos
p, String
rs)
            scan' (Char
'*'     :String
rs)      = (String -> Pos -> Token
reserved String
"*" Pos
p, Column -> Pos -> Pos
advc Column
1 Pos
p, String
rs)

            scan' (Char
'\''    :String
rs) | Options -> Bool
ocaml Options
opts =  -- note: ocaml type variables are encoded as 'TkTextnm' tokens

              let (String
var,String
rest) = Options -> String -> (String, String)
ident Options
opts String
rs
                  str :: String
str = Char
'\'' Char -> String -> String
forall a. a -> [a] -> [a]
: String
var
              in (EnumValToken -> String -> Pos -> Token
valueToken EnumValToken
TkTextnm String
str Pos
p, Column -> Pos -> Pos
advc (String -> Column
forall (t :: * -> *) a. Foldable t => t a -> Column
length String
str) Pos
p, String
rest)

            scan' (Char
x:String
rs) | Char -> Bool
isLower Char
x = let (String
var,String
rest) = Options -> String -> (String, String)
ident Options
opts String
rs
                                           str :: String
str        = (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
var)
                                           tok :: Pos -> Token
tok | String
str String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
keywords' = String -> Pos -> Token
reserved (String -> String
mkKeyword String
str)
                                               | Bool
otherwise            = EnumValToken -> String -> Pos -> Token
valueToken EnumValToken
TkVarid String
str
                                       in (Pos -> Token
tok Pos
p, Column -> Pos -> Pos
advc (String -> Column
forall (t :: * -> *) a. Foldable t => t a -> Column
length String
varColumn -> Column -> Column
forall a. Num a => a -> a -> a
+Column
1) Pos
p, String
rest)
                         | Char -> Bool
isUpper Char
x = let (String
var,String
rest) = Options -> String -> (String, String)
ident Options
opts String
rs
                                           str :: String
str        = (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
var)
                                           tok :: Pos -> Token
tok | String
str String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
keywords' = String -> Pos -> Token
reserved (String -> String
mkKeyword String
str)
                                               | Bool
otherwise            = EnumValToken -> String -> Pos -> Token
valueToken EnumValToken
TkConid String
str
                                       in (Pos -> Token
tok Pos
p, Column -> Pos -> Pos
advc (String -> Column
forall (t :: * -> *) a. Foldable t => t a -> Column
length String
varColumn -> Column -> Column
forall a. Num a => a -> a -> a
+Column
1) Pos
p,String
rest)
                         | Bool
otherwise = (String -> Pos -> Token
errToken (String
"unexpected character " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
x) Pos
p, Column -> Pos -> Pos
advc Column
1 Pos
p, String
rs)

    scanBeginOfLine :: Lexer Token
    scanBeginOfLine :: Lexer Token
scanBeginOfLine Pos
p (Char
'{' : Char
'-' : Char
' ' : Char
'L' : Char
'I' : Char
'N' : Char
'E' : Char
' ' : String
xs)
      | String -> Bool
isOkBegin String
rs Bool -> Bool -> Bool
&& String -> Bool
isOkEnd String
rs'
          = Lexer Token
scan (Column -> Pos -> Pos
advc (Column
8 Column -> Column -> Column
forall a. Num a => a -> a -> a
+ String -> Column
forall (t :: * -> *) a. Foldable t => t a -> Column
length String
r Column -> Column -> Column
forall a. Num a => a -> a -> a
+ Column
2 Column -> Column -> Column
forall a. Num a => a -> a -> a
+ String -> Column
forall (t :: * -> *) a. Foldable t => t a -> Column
length String
s Column -> Column -> Column
forall a. Num a => a -> a -> a
+ Column
4) Pos
p') (Column -> String -> String
forall a. Column -> [a] -> [a]
drop Column
4 String
rs')
      | Bool
otherwise
          = (Token, Pos, String) -> Maybe (Token, Pos, String)
forall a. a -> Maybe a
Just (String -> Pos -> Token
errToken (String
"Invalid LINE pragma: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
r) Pos
p, Column -> Pos -> Pos
advc Column
8 Pos
p, String
xs)
      where
        (String
r,String
rs)   = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
xs
        (String
s, String
rs') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"') (Column -> String -> String
forall a. Column -> [a] -> [a]
drop Column
2 String
rs)
        p' :: Pos
p' = Column -> Column -> String -> Pos
Pos (String -> Column
forall a. Read a => String -> a
read String
r Column -> Column -> Column
forall a. Num a => a -> a -> a
- Column
1) (Pos -> Column
forall p. Position p => p -> Column
column Pos
p) String
s    -- LINE pragma indicates the line number of the /next/ line!


        isOkBegin :: String -> Bool
isOkBegin (Char
' ' : Char
'"' : String
_) = Bool
True
        isOkBegin String
_               = Bool
False

        isOkEnd :: String -> Bool
isOkEnd (Char
'"' : Char
' ' : Char
'-' : Char
'}' : String
_) = Bool
True
        isOkEnd String
_         = Bool
False
    scanBeginOfLine Pos
p String
xs
      = Lexer Token
scan Pos
p String
xs


ident :: Options -> String -> (String, String)
ident Options
opts = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isValid
 where isValid :: Char -> Bool
isValid 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
||
                   (Bool -> Bool
not (Options -> Bool
clean Options
opts) Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'') Bool -> Bool -> Bool
|| (Options -> Bool
clean Options
opts Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'`')

lowercaseKeywords :: [String]
lowercaseKeywords = [String
"loc",String
"lhs", String
"inst", String
"optpragmas", String
"imports", String
"toplevel", String
"datablock", String
"recblock"]
keywords :: [String]
keywords = [String]
lowercaseKeywords [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
           [ String
"DATA", String
"RECORD", String
"EXT", String
"ATTR", String
"SEM",String
"TYPE", String
"USE", String
"INCLUDE"
           , String
"EXTENDS" -- marcos

           , String
"SET",String
"DERIVING",String
"FOR", String
"WRAPPER", String
"NOCATAS", String
"MAYBE", String
"EITHER", String
"MAP", String
"INTMAP"
           , String
"PRAGMA", String
"SEMPRAGMA", String
"MODULE", String
"ATTACH", String
"UNIQUEREF", String
"INH", String
"SYN", String
"CHN"
           , String
"AUGMENT", String
"AROUND", String
"MERGE", String
"AS", String
"SELF", String
"INTSET"
           ]

ncomment :: (Pos -> String -> Maybe (Token, Pos, [a]))
-> Pos -> String -> Maybe (Token, Pos, [a])
ncomment Pos -> String -> Maybe (Token, Pos, [a])
c Pos
p (Char
'-':Char
'}':String
xs) = Column
-> Pos
-> (Pos -> String -> Maybe (Token, Pos, [a]))
-> String
-> Maybe (Token, Pos, [a])
forall a. Column -> Pos -> (Pos -> a) -> a
advc' Column
2 Pos
p Pos -> String -> Maybe (Token, Pos, [a])
c  String
xs
ncomment Pos -> String -> Maybe (Token, Pos, [a])
c Pos
p (Char
'{':Char
'-':String
xs) = Column
-> Pos
-> (Pos -> String -> Maybe (Token, Pos, [a]))
-> String
-> Maybe (Token, Pos, [a])
forall a. Column -> Pos -> (Pos -> a) -> a
advc' Column
2 Pos
p ((Pos -> String -> Maybe (Token, Pos, [a]))
-> Pos -> String -> Maybe (Token, Pos, [a])
ncomment ((Pos -> String -> Maybe (Token, Pos, [a]))
-> Pos -> String -> Maybe (Token, Pos, [a])
ncomment Pos -> String -> Maybe (Token, Pos, [a])
c)) String
xs
ncomment Pos -> String -> Maybe (Token, Pos, [a])
c Pos
p (Char
x:String
xs)       = Char
-> Pos
-> (Pos -> String -> Maybe (Token, Pos, [a]))
-> String
-> Maybe (Token, Pos, [a])
forall a. Char -> Pos -> (Pos -> a) -> a
updPos' Char
x Pos
p ((Pos -> String -> Maybe (Token, Pos, [a]))
-> Pos -> String -> Maybe (Token, Pos, [a])
ncomment Pos -> String -> Maybe (Token, Pos, [a])
c)  String
xs
ncomment Pos -> String -> Maybe (Token, Pos, [a])
c Pos
p []           = (Token, Pos, [a]) -> Maybe (Token, Pos, [a])
forall a. a -> Maybe a
Just (String -> Pos -> Token
errToken String
"unterminated nested comment" Pos
p, Pos
p,[])

cleancomment :: (Pos -> String -> Maybe (Token, Pos, [a]))
-> Pos -> String -> Maybe (Token, Pos, [a])
cleancomment Pos -> String -> Maybe (Token, Pos, [a])
c Pos
p (Char
'*':Char
'/':String
xs) = Column
-> Pos
-> (Pos -> String -> Maybe (Token, Pos, [a]))
-> String
-> Maybe (Token, Pos, [a])
forall a. Column -> Pos -> (Pos -> a) -> a
advc' Column
2 Pos
p Pos -> String -> Maybe (Token, Pos, [a])
c  String
xs
cleancomment Pos -> String -> Maybe (Token, Pos, [a])
c Pos
p (Char
'/':Char
'*':String
xs) = Column
-> Pos
-> (Pos -> String -> Maybe (Token, Pos, [a]))
-> String
-> Maybe (Token, Pos, [a])
forall a. Column -> Pos -> (Pos -> a) -> a
advc' Column
2 Pos
p ((Pos -> String -> Maybe (Token, Pos, [a]))
-> Pos -> String -> Maybe (Token, Pos, [a])
cleancomment ((Pos -> String -> Maybe (Token, Pos, [a]))
-> Pos -> String -> Maybe (Token, Pos, [a])
cleancomment Pos -> String -> Maybe (Token, Pos, [a])
c)) String
xs
cleancomment Pos -> String -> Maybe (Token, Pos, [a])
c Pos
p (Char
x:String
xs)       = Char
-> Pos
-> (Pos -> String -> Maybe (Token, Pos, [a]))
-> String
-> Maybe (Token, Pos, [a])
forall a. Char -> Pos -> (Pos -> a) -> a
updPos' Char
x Pos
p ((Pos -> String -> Maybe (Token, Pos, [a]))
-> Pos -> String -> Maybe (Token, Pos, [a])
cleancomment Pos -> String -> Maybe (Token, Pos, [a])
c)  String
xs
cleancomment Pos -> String -> Maybe (Token, Pos, [a])
c Pos
p []           = (Token, Pos, [a]) -> Maybe (Token, Pos, [a])
forall a. a -> Maybe a
Just (String -> Pos -> Token
errToken String
"unterminated nested comment" Pos
p, Pos
p,[])

codescrap :: Lexer Token
codescrap Pos
p String
xs = let (Pos
p2,String
xs2,String
sc) = Integer -> Pos -> String -> (Pos, String, String)
forall t.
(Eq t, Num t) =>
t -> Pos -> String -> (Pos, String, String)
codescrap' Integer
1 Pos
p String
xs
                 in case String
xs2 of
                         (Char
'}':String
rest) -> (Token, Pos, String) -> Maybe (Token, Pos, String)
forall a. a -> Maybe a
Just (EnumValToken -> String -> Pos -> Token
valueToken EnumValToken
TkTextln String
sc Pos
p,Column -> Pos -> Pos
advc Column
1 Pos
p2,String
rest)
                         String
_          -> (Token, Pos, String) -> Maybe (Token, Pos, String)
forall a. a -> Maybe a
Just (String -> Pos -> Token
errToken String
"unterminated codescrap" Pos
p,Pos
p2,String
xs2)


codescrap' :: t -> Pos -> String -> (Pos, String, String)
codescrap' t
d Pos
p [] = (Pos
p,[],[])
{-
codescrap' d p ('{':'{':xs) = let (p2,xs2,sc) = advc' 2 p (codescrap' d) xs
                              in (p2,xs2,'{':' ':sc)
codescrap' d p ('}':'}':xs) = let (p2,xs2,sc) = advc' 2 p (codescrap' d) xs
                              in (p2,xs2,'}':' ':sc)
-}
codescrap' t
d Pos
p (Char
'{':String
xs)     = let (Pos
p2,String
xs2,String
sc) = Column
-> Pos
-> (Pos -> String -> (Pos, String, String))
-> String
-> (Pos, String, String)
forall a. Column -> Pos -> (Pos -> a) -> a
advc' Column
1 Pos
p (t -> Pos -> String -> (Pos, String, String)
codescrap' (t
dt -> t -> t
forall a. Num a => a -> a -> a
+t
1)) String
xs
                              in (Pos
p2,String
xs2,Char
'{' Char -> String -> String
forall a. a -> [a] -> [a]
: String
sc)
codescrap' t
d Pos
p (Char
'}':String
xs)     | t
d t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
1 = (Pos
p,Char
'}'Char -> String -> String
forall a. a -> [a] -> [a]
:String
xs,[])
                            | Bool
otherwise = let (Pos
p2,String
xs2,String
sc) = Column
-> Pos
-> (Pos -> String -> (Pos, String, String))
-> String
-> (Pos, String, String)
forall a. Column -> Pos -> (Pos -> a) -> a
advc' Column
1 Pos
p (t -> Pos -> String -> (Pos, String, String)
codescrap' (t
dt -> t -> t
forall a. Num a => a -> a -> a
-t
1)) String
xs
                                          in (Pos
p2,String
xs2,Char
'}' Char -> String -> String
forall a. a -> [a] -> [a]
: String
sc)
codescrap' t
d Pos
p (Char
x  :String
xs)     = let (Pos
p2,String
xs2,String
sc) = Char
-> Pos
-> (Pos -> String -> (Pos, String, String))
-> String
-> (Pos, String, String)
forall a. Char -> Pos -> (Pos -> a) -> a
updPos' Char
x Pos
p (t -> Pos -> String -> (Pos, String, String)
codescrap' t
d) String
xs
                              in (Pos
p2,String
xs2,Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
sc)
--Literate Mode

scanLit :: String -> ([String], String)
scanLit String
xs = ([String]
fs, ((Column, String) -> (Column -> String) -> Column -> String)
-> (Column -> String) -> [(Column, String)] -> Column -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Column, String) -> (Column -> String) -> Column -> String
insNL (String -> Column -> String
forall a b. a -> b -> a
const String
"") [(Column, String)]
codeLns Column
1)
  where insNL :: (Column, String) -> (Column -> String) -> Column -> String
insNL (Column
n,String
line) Column -> String
r = \Column
n1 -> Column -> Char -> String
forall a. Column -> a -> [a]
replicate (Column
nColumn -> Column -> Column
forall a. Num a => a -> a -> a
-Column
n1) Char
'\n' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
line String -> String -> String
forall a. [a] -> [a] -> [a]
++ Column -> String
r Column
n
        ([String]
fs,[(Column, String)]
codeLns,[Any]
_) = [(Column, String)] -> ([String], [(Column, String)], [Any])
forall a a. [(a, String)] -> ([String], [(a, String)], [a])
getBlocks ([Column
1..] [Column] -> [String] -> [(Column, String)]
forall a b. [a] -> [b] -> [(a, b)]
`zip`  String -> [String]
toLines String
xs)
        getBlocks :: [(a, String)] -> ([String], [(a, String)], [a])
getBlocks [] = ([],[],[])
        getBlocks [(a, String)]
xs = let ([String]
files1,[(a, String)]
txt1,[(a, String)]
r1) = [(a, String)] -> ([String], [(a, String)], [(a, String)])
forall a. [(a, String)] -> ([String], [(a, String)], [(a, String)])
getBlock [(a, String)]
xs
                           ([String]
files2,[(a, String)]
txt2,[a]
r2) = [(a, String)] -> ([String], [(a, String)], [a])
getBlocks [(a, String)]
r1
                       in ([String]
files1[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String]
files2, [(a, String)]
txt1[(a, String)] -> [(a, String)] -> [(a, String)]
forall a. [a] -> [a] -> [a]
++[(a, String)]
txt2, [a]
r2)


        getBlock :: [(a, String)] -> ([String], [(a, String)], [(a, String)])
getBlock = [(a, String)] -> ([String], [(a, String)], [(a, String)])
getLines ([(a, String)] -> ([String], [(a, String)], [(a, String)]))
-> ([(a, String)] -> [(a, String)])
-> [(a, String)]
-> ([String], [(a, String)], [(a, String)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, String) -> Bool) -> [(a, String)] -> [(a, String)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (a, String) -> Bool
forall a. (a, String) -> Bool
comment
        getLines :: [(a, String)] -> ([String], [(a, String)], [(a, String)])
getLines [] = ([],[],[])
        getLines ((a
n,String
l):[(a, String)]
ls) | String
"\\begin{code}" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
l = let ([(a, String)]
lns,[(a, String)]
rest) = [(a, String)] -> ([(a, String)], [(a, String)])
forall a. [(a, String)] -> ([(a, String)], [(a, String)])
codelines [(a, String)]
ls
                                                               in ([],[(a, String)]
lns,[(a, String)]
rest)
                            | String
"\\begin{Code}" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
l = let ([(a, String)]
lns,[(a, String)]
rest) = [(a, String)] -> ([(a, String)], [(a, String)])
forall a. [(a, String)] -> ([(a, String)], [(a, String)])
codeLines [(a, String)]
ls
                                                               in ([],[(a, String)]
lns,[(a, String)]
rest)
                            | String
"\\IN{" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
l        =
                                     let name :: String
name = String -> String
getName String
l
                                     in  ([String
name],[],[(a, String)]
ls)
                            | Bool
otherwise = [(a, String)] -> ([String], [(a, String)], [(a, String)])
getBlock [(a, String)]
ls
        comment :: (a, String) -> Bool
comment = Bool -> Bool
not (Bool -> Bool) -> ((a, String) -> Bool) -> (a, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"\\" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) (String -> Bool) -> ((a, String) -> String) -> (a, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a, String) -> String
forall a b. (a, b) -> b
snd

toLines     :: String -> [String]
toLines :: String -> [String]
toLines String
""   = []
toLines String
s    = let (String
l,String
s') = String -> (String, String)
breakLine String
s
               in String
l String -> [String] -> [String]
forall a. a -> [a] -> [a]
:  String -> [String]
toLines String
s'
breakLine :: String -> (String, String)
breakLine String
xs = case String
xs of
                Char
'\CR' : String
ys -> case String
ys of
                                Char
'\LF' : String
zs -> ([],String
zs)
                                String
_          -> ([],String
ys)
                Char
'\LF' : String
ys -> ([], String
ys)
                Char
x     : String
ys -> let (String
l,String
s) = String -> (String, String)
breakLine String
ys
                              in (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
l,String
s)
                []         -> ([],[])

codelines :: [(a, String)] -> ([(a, String)], [(a, String)])
codelines [] = String -> ([(a, String)], [(a, String)])
forall a. HasCallStack => String -> a
error String
"Unterminated literate code block"
codelines ((a
n,String
l):[(a, String)]
ls) | String
"\\end{code}" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
l = ([],[(a, String)]
ls)
                     | Bool
otherwise                    = let ([(a, String)]
lns,[(a, String)]
r) = [(a, String)] -> ([(a, String)], [(a, String)])
codelines [(a, String)]
ls
                                                      in ((a
n,String
l)(a, String) -> [(a, String)] -> [(a, String)]
forall a. a -> [a] -> [a]
:[(a, String)]
lns,[(a, String)]
r)

codeLines :: [(a, String)] -> ([(a, String)], [(a, String)])
codeLines [] = String -> ([(a, String)], [(a, String)])
forall a. HasCallStack => String -> a
error String
"Unterminated literate Code block"
codeLines ((a
n,String
l):[(a, String)]
ls) | String
"\\end{Code}" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
l = ([],[(a, String)]
ls)
                     | Bool
otherwise                    = let ([(a, String)]
lns,[(a, String)]
r) = [(a, String)] -> ([(a, String)], [(a, String)])
codeLines [(a, String)]
ls
                                                      in ((a
n,String
l)(a, String) -> [(a, String)] -> [(a, String)]
forall a. a -> [a] -> [a]
:[(a, String)]
lns,[(a, String)]
r)

getName :: String -> String
getName String
l = case String
r of
   (Char
'}':String
_) -> String
nm
   String
_       -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"missing '}' in \\IN"
 where (String
nm,String
r) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'}') (Column -> String -> String
forall a. Column -> [a] -> [a]
drop Column
4 String
l)