{-# OPTIONS -w #-}

module Lambdabot.Plugin.Haskell.Free.Parse where

import Control.Applicative
import Control.Monad
import Control.Monad.Fail (MonadFail)
import qualified Control.Monad.Fail

data Token
    = QVarId String
    | QConId String
    | QVarSym String
    | QConSym String
    | OpenParen
    | CloseParen
    | Comma
    | Semicolon
    | OpenBracket
    | CloseBracket
    | BackQuote
    | OpenBrace
    | CloseBrace
    | OpDotDot
    | OpColon
    | OpColonColon
    | OpEquals
    | OpBackslash
    | OpPipe
    | OpBackArrow
    | OpArrow
    | OpAt
    | OpTilde
    | OpImplies
    | IdCase
    | IdClass
    | IdData
    | IdDefault
    | IdDeriving
    | IdDo
    | IdElse
    | IdForall
    | IdIf
    | IdImport
    | IdIn
    | IdInfix
    | IdInfixl
    | IdInfixr
    | IdInstance
    | IdLet
    | IdModule
    | IdNewtype
    | IdOf
    | IdThen
    | IdType
    | IdWhere
    | IdUscore
    | TokError String
        deriving (Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show,Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c== :: Token -> Token -> Bool
Eq,Eq Token
Eq Token
-> (Token -> Token -> Ordering)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Token)
-> (Token -> Token -> Token)
-> Ord Token
Token -> Token -> Bool
Token -> Token -> Ordering
Token -> Token -> Token
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Token -> Token -> Token
$cmin :: Token -> Token -> Token
max :: Token -> Token -> Token
$cmax :: Token -> Token -> Token
>= :: Token -> Token -> Bool
$c>= :: Token -> Token -> Bool
> :: Token -> Token -> Bool
$c> :: Token -> Token -> Bool
<= :: Token -> Token -> Bool
$c<= :: Token -> Token -> Bool
< :: Token -> Token -> Bool
$c< :: Token -> Token -> Bool
compare :: Token -> Token -> Ordering
$ccompare :: Token -> Token -> Ordering
$cp1Ord :: Eq Token
Ord)

data ParseResult a
    = ParseSuccess a [Token]
    | ParseError String
        deriving (Int -> ParseResult a -> ShowS
[ParseResult a] -> ShowS
ParseResult a -> String
(Int -> ParseResult a -> ShowS)
-> (ParseResult a -> String)
-> ([ParseResult a] -> ShowS)
-> Show (ParseResult a)
forall a. Show a => Int -> ParseResult a -> ShowS
forall a. Show a => [ParseResult a] -> ShowS
forall a. Show a => ParseResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseResult a] -> ShowS
$cshowList :: forall a. Show a => [ParseResult a] -> ShowS
show :: ParseResult a -> String
$cshow :: forall a. Show a => ParseResult a -> String
showsPrec :: Int -> ParseResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ParseResult a -> ShowS
Show)

newtype ParseS a = ParseS { ParseS a -> [Token] -> ParseResult a
parse :: [Token] -> ParseResult a }

instance Functor ParseS where
    fmap :: (a -> b) -> ParseS a -> ParseS b
fmap = (a -> b) -> ParseS a -> ParseS b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative ParseS where
    pure :: a -> ParseS a
pure = a -> ParseS a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: ParseS (a -> b) -> ParseS a -> ParseS b
(<*>) = ParseS (a -> b) -> ParseS a -> ParseS b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad ParseS where
    return :: a -> ParseS a
return a
x = ([Token] -> ParseResult a) -> ParseS a
forall a. ([Token] -> ParseResult a) -> ParseS a
ParseS (\[Token]
ts -> a -> [Token] -> ParseResult a
forall a. a -> [Token] -> ParseResult a
ParseSuccess a
x [Token]
ts)
    ParseS a
m >>= :: ParseS a -> (a -> ParseS b) -> ParseS b
>>= a -> ParseS b
k = ([Token] -> ParseResult b) -> ParseS b
forall a. ([Token] -> ParseResult a) -> ParseS a
ParseS (\[Token]
ts -> case ParseS a -> [Token] -> ParseResult a
forall a. ParseS a -> [Token] -> ParseResult a
parse ParseS a
m [Token]
ts of
                                ParseSuccess a
x [Token]
ts' -> ParseS b -> [Token] -> ParseResult b
forall a. ParseS a -> [Token] -> ParseResult a
parse (a -> ParseS b
k a
x) [Token]
ts'
                                ParseError String
s       -> String -> ParseResult b
forall a. String -> ParseResult a
ParseError String
s)

instance MonadFail ParseS where
    fail :: String -> ParseS a
fail String
str = ([Token] -> ParseResult a) -> ParseS a
forall a. ([Token] -> ParseResult a) -> ParseS a
ParseS (\[Token]
_ -> String -> ParseResult a
forall a. String -> ParseResult a
ParseError String
str)

instance Alternative ParseS where
    empty :: ParseS a
empty = ParseS a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    <|> :: ParseS a -> ParseS a -> ParseS a
(<|>) = ParseS a -> ParseS a -> ParseS a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance MonadPlus ParseS where
    mzero :: ParseS a
mzero = ([Token] -> ParseResult a) -> ParseS a
forall a. ([Token] -> ParseResult a) -> ParseS a
ParseS (\[Token]
ts -> String -> ParseResult a
forall a. String -> ParseResult a
ParseError String
"parse error")
    mplus :: ParseS a -> ParseS a -> ParseS a
mplus ParseS a
m1 ParseS a
m2
        = ([Token] -> ParseResult a) -> ParseS a
forall a. ([Token] -> ParseResult a) -> ParseS a
ParseS (\[Token]
ts -> case ParseS a -> [Token] -> ParseResult a
forall a. ParseS a -> [Token] -> ParseResult a
parse ParseS a
m1 [Token]
ts of
                            res :: ParseResult a
res@(ParseSuccess a
_ [Token]
_) -> ParseResult a
res
                            ParseError String
_           -> ParseS a -> [Token] -> ParseResult a
forall a. ParseS a -> [Token] -> ParseResult a
parse ParseS a
m2 [Token]
ts)

peekToken :: ParseS (Maybe Token)
peekToken :: ParseS (Maybe Token)
peekToken = ([Token] -> ParseResult (Maybe Token)) -> ParseS (Maybe Token)
forall a. ([Token] -> ParseResult a) -> ParseS a
ParseS (\[Token]
ts -> case [Token]
ts of
                            []     -> Maybe Token -> [Token] -> ParseResult (Maybe Token)
forall a. a -> [Token] -> ParseResult a
ParseSuccess Maybe Token
forall a. Maybe a
Nothing []
                            (Token
t':[Token]
_) -> Maybe Token -> [Token] -> ParseResult (Maybe Token)
forall a. a -> [Token] -> ParseResult a
ParseSuccess (Token -> Maybe Token
forall a. a -> Maybe a
Just Token
t') [Token]
ts)

getToken :: ParseS (Maybe Token)
getToken :: ParseS (Maybe Token)
getToken = ([Token] -> ParseResult (Maybe Token)) -> ParseS (Maybe Token)
forall a. ([Token] -> ParseResult a) -> ParseS a
ParseS (\[Token]
ts -> case [Token]
ts of
                            []     -> Maybe Token -> [Token] -> ParseResult (Maybe Token)
forall a. a -> [Token] -> ParseResult a
ParseSuccess Maybe Token
forall a. Maybe a
Nothing []
                            (Token
t:[Token]
ts) -> Maybe Token -> [Token] -> ParseResult (Maybe Token)
forall a. a -> [Token] -> ParseResult a
ParseSuccess (Token -> Maybe Token
forall a. a -> Maybe a
Just Token
t) [Token]
ts)

match :: Token -> ParseS ()
match :: Token -> ParseS ()
match Token
m
    = do
        Maybe Token
mt <- ParseS (Maybe Token)
getToken
        case Maybe Token
mt of
            Just Token
t | Token
t Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
m -> () -> ParseS ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Maybe Token
_               -> String -> ParseS ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Expected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Token -> String
forall a. Show a => a -> String
show Token
m)

ascSymbol :: String
ascSymbol = [Char
'!',Char
'#',Char
'$',Char
'%',Char
'&',Char
'*',Char
'+',Char
'.',Char
'/',Char
'<',Char
'=',Char
'>',Char
'?',Char
'@',Char
'\\',
                Char
'^',Char
'|',Char
'-',Char
'~']


lexer :: String -> [Token]
lexer :: String -> [Token]
lexer []
    = []
lexer (Char
' ':String
cs)
    = String -> [Token]
lexer String
cs
lexer (Char
'\t':String
cs)
    = String -> [Token]
lexer String
cs
lexer (Char
'\f':String
cs)
    = String -> [Token]
lexer String
cs
lexer (Char
'\r':String
cs)
    = String -> [Token]
lexer String
cs
lexer (Char
'\n':String
cs)
    = String -> [Token]
lexer String
cs
lexer (Char
'\v':String
cs)
    = String -> [Token]
lexer String
cs
lexer (Char
'-':Char
'-':String
cs)
    = String -> [Token]
lexerLineComment String
cs
    where
        lexerLineComment :: String -> [Token]
lexerLineComment (Char
'\r':Char
'\n':String
cs) = String -> [Token]
lexer String
cs
        lexerLineComment (Char
'\r':String
cs) = String -> [Token]
lexer String
cs
        lexerLineComment (Char
'\n':String
cs) = String -> [Token]
lexer String
cs
        lexerLineComment (Char
'\f':String
cs) = String -> [Token]
lexer String
cs
        lexerLineComment (Char
c:String
cs) = String -> [Token]
lexerLineComment String
cs
        lexerLineComment [] = []
lexer (Char
'{':Char
'-':String
cs)
    = (String -> [Token]) -> String -> [Token]
lexerComment String -> [Token]
lexer String
cs
    where
        lexerComment :: (String -> [Token]) -> String -> [Token]
lexerComment String -> [Token]
k (Char
'{':Char
'-':String
cs) = (String -> [Token]) -> String -> [Token]
lexerComment ((String -> [Token]) -> String -> [Token]
lexerComment String -> [Token]
k) String
cs
        lexerComment String -> [Token]
k (Char
'-':Char
'}':String
cs) = String -> [Token]
k String
cs
        lexerComment String -> [Token]
k (Char
_:String
cs) = (String -> [Token]) -> String -> [Token]
lexerComment String -> [Token]
k String
cs
        lexerComment String -> [Token]
k [] = [String -> Token
TokError String
"Unterminated comment"]
lexer (Char
'(':String
cs)
    = Token
OpenParen Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
lexer (Char
')':String
cs)
    = Token
CloseParen Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
lexer (Char
',':String
cs)
    = Token
Comma Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
lexer (Char
'[':String
cs)
    = Token
OpenBracket Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
lexer (Char
']':String
cs)
    = Token
CloseBracket Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
lexer (c :: Char
c@Char
':':String
cs)
    = String -> String -> [Token]
lexerConSym [Char
c] String
cs
    where
        lexerConSym :: String -> String -> [Token]
lexerConSym String
con (Char
c:String
cs)
            | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':'
                Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
ascSymbol
                = String -> String -> [Token]
lexerConSym (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
con) String
cs
        lexerConSym String
con String
cs
            = case ShowS
forall a. [a] -> [a]
reverse String
con of
                String
":"  -> Token
OpColon Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                String
"::" -> Token
OpColonColon Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                String
con  -> String -> Token
QConSym String
con Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
lexer (Char
c:String
cs)
    | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'A'..Char
'Z']
        = String -> String -> [Token]
lexerConId [Char
c] String
cs
    | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'a'..Char
'z'] Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
        = String -> String -> [Token]
lexerVarId [Char
c] String
cs
    | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
ascSymbol
        = String -> String -> [Token]
lexerVarSym [Char
c] String
cs
    | Bool
otherwise
        = [String -> Token
TokError String
"Illegal char"]
        where
            lexerConId :: String -> String -> [Token]
lexerConId String
con (Char
c:String
cs)
                | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'A'..Char
'Z']
                    Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'a'..Char
'z']
                    Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'0'..Char
'9']
                    Bool -> Bool -> Bool
|| 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
'_'
                        = String -> String -> [Token]
lexerConId (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
con) String
cs
            lexerConId String
con String
cs
                = String -> Token
QConId (ShowS
forall a. [a] -> [a]
reverse String
con) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs

            lexerVarId :: String -> String -> [Token]
lexerVarId String
var (Char
c:String
cs)
                | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'A'..Char
'Z']
                    Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'a'..Char
'z']
                    Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'0'..Char
'9']
                    Bool -> Bool -> Bool
|| 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
'_'
                        = String -> String -> [Token]
lexerVarId (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
var) String
cs
            lexerVarId String
var String
cs
                = case ShowS
forall a. [a] -> [a]
reverse String
var of
                    String
"_"        -> Token
IdUscore Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"case"     -> Token
IdCase Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"class"    -> Token
IdClass Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"data"     -> Token
IdData Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"default"  -> Token
IdDefault Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"deriving" -> Token
IdDeriving Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"do"       -> Token
IdDo Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"else"     -> Token
IdElse Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"forall"   -> Token
IdForall Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"if"       -> Token
IdIf Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"import"   -> Token
IdImport Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"in"       -> Token
IdIn Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"infix"    -> Token
IdInfix Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"infixl"   -> Token
IdInfixl Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"infixr"   -> Token
IdInfixr Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"instance" -> Token
IdInstance Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"let"      -> Token
IdLet Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"module"   -> Token
IdModule Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"newtype"  -> Token
IdNewtype Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"of"       -> Token
IdOf Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"then"     -> Token
IdThen Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"type"     -> Token
IdType Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"where"    -> Token
IdWhere Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
v          -> String -> Token
QVarId String
v Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs

            lexerVarSym :: String -> String -> [Token]
lexerVarSym String
var (Char
c:String
cs)
                | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':' Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
ascSymbol
                    = String -> String -> [Token]
lexerVarSym (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
var) String
cs
            lexerVarSym String
var String
cs
                = case ShowS
forall a. [a] -> [a]
reverse String
var of
                    String
".."    -> Token
OpDotDot Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"="     -> Token
OpEquals Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"\\"    -> Token
OpBackslash Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"|"     -> Token
OpPipe Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"<-"    -> Token
OpBackArrow Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"->"    -> Token
OpArrow Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"@"     -> Token
OpAt Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"~"     -> Token
OpTilde Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
"=>"    -> Token
OpImplies Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
                    String
var     -> String -> Token
QVarSym String
var Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs

-- vim: ts=4:sts=4:expandtab:ai