{-# 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 x :: a
x = ([Token] -> ParseResult a) -> ParseS a
forall a. ([Token] -> ParseResult a) -> ParseS a
ParseS (\ts :: [Token]
ts -> a -> [Token] -> ParseResult a
forall a. a -> [Token] -> ParseResult a
ParseSuccess a
x [Token]
ts)
m :: ParseS a
m >>= :: ParseS a -> (a -> ParseS b) -> ParseS b
>>= k :: a -> ParseS b
k = ([Token] -> ParseResult b) -> ParseS b
forall a. ([Token] -> ParseResult a) -> ParseS a
ParseS (\ts :: [Token]
ts -> case ParseS a -> [Token] -> ParseResult a
forall a. ParseS a -> [Token] -> ParseResult a
parse ParseS a
m [Token]
ts of
ParseSuccess x :: a
x ts' :: [Token]
ts' -> ParseS b -> [Token] -> ParseResult b
forall a. ParseS a -> [Token] -> ParseResult a
parse (a -> ParseS b
k a
x) [Token]
ts'
ParseError s :: String
s -> String -> ParseResult b
forall a. String -> ParseResult a
ParseError String
s)
instance MonadFail ParseS where
fail :: String -> ParseS a
fail str :: String
str = ([Token] -> ParseResult a) -> ParseS a
forall a. ([Token] -> ParseResult a) -> ParseS a
ParseS (\_ -> 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 (\ts :: [Token]
ts -> String -> ParseResult a
forall a. String -> ParseResult a
ParseError "parse error")
mplus :: ParseS a -> ParseS a -> ParseS a
mplus m1 :: ParseS a
m1 m2 :: ParseS a
m2
= ([Token] -> ParseResult a) -> ParseS a
forall a. ([Token] -> ParseResult a) -> ParseS a
ParseS (\ts :: [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 _ _) -> ParseResult a
res
ParseError _ -> 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 (\ts :: [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 []
(t' :: Token
t':_) -> 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 (\ts :: [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 []
(t :: Token
t:ts :: [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 m :: Token
m
= do
Maybe Token
mt <- ParseS (Maybe Token)
getToken
case Maybe Token
mt of
Just t :: 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 ()
_ -> String -> ParseS ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("Expected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Token -> String
forall a. Show a => a -> String
show Token
m)
ascSymbol :: String
ascSymbol = ['!','#','$','%','&','*','+','.','/','<','=','>','?','@','\\',
'^','|','-','~']
lexer :: String -> [Token]
lexer :: String -> [Token]
lexer []
= []
lexer (' ':cs :: String
cs)
= String -> [Token]
lexer String
cs
lexer ('\t':cs :: String
cs)
= String -> [Token]
lexer String
cs
lexer ('\f':cs :: String
cs)
= String -> [Token]
lexer String
cs
lexer ('\r':cs :: String
cs)
= String -> [Token]
lexer String
cs
lexer ('\n':cs :: String
cs)
= String -> [Token]
lexer String
cs
lexer ('\v':cs :: String
cs)
= String -> [Token]
lexer String
cs
lexer ('-':'-':cs :: String
cs)
= String -> [Token]
lexerLineComment String
cs
where
lexerLineComment :: String -> [Token]
lexerLineComment ('\r':'\n':cs :: String
cs) = String -> [Token]
lexer String
cs
lexerLineComment ('\r':cs :: String
cs) = String -> [Token]
lexer String
cs
lexerLineComment ('\n':cs :: String
cs) = String -> [Token]
lexer String
cs
lexerLineComment ('\f':cs :: String
cs) = String -> [Token]
lexer String
cs
lexerLineComment (c :: Char
c:cs :: String
cs) = String -> [Token]
lexerLineComment String
cs
lexerLineComment [] = []
lexer ('{':'-':cs :: String
cs)
= (String -> [Token]) -> String -> [Token]
lexerComment String -> [Token]
lexer String
cs
where
lexerComment :: (String -> [Token]) -> String -> [Token]
lexerComment k :: String -> [Token]
k ('{':'-':cs :: String
cs) = (String -> [Token]) -> String -> [Token]
lexerComment ((String -> [Token]) -> String -> [Token]
lexerComment String -> [Token]
k) String
cs
lexerComment k :: String -> [Token]
k ('-':'}':cs :: String
cs) = String -> [Token]
k String
cs
lexerComment k :: String -> [Token]
k (_:cs :: String
cs) = (String -> [Token]) -> String -> [Token]
lexerComment String -> [Token]
k String
cs
lexerComment k :: String -> [Token]
k [] = [String -> Token
TokError "Unterminated comment"]
lexer ('(':cs :: String
cs)
= Token
OpenParen Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
lexer (')':cs :: String
cs)
= Token
CloseParen Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
lexer (',':cs :: String
cs)
= Token
Comma Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
lexer ('[':cs :: String
cs)
= Token
OpenBracket Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
lexer (']':cs :: String
cs)
= Token
CloseBracket Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
lexer (c :: Char
c@Char
':':cs :: String
cs)
= String -> String -> [Token]
lexerConSym [Char
c] String
cs
where
lexerConSym :: String -> String -> [Token]
lexerConSym con :: String
con (c :: Char
c:cs :: String
cs)
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ':'
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 con :: String
con cs :: String
cs
= case ShowS
forall a. [a] -> [a]
reverse String
con of
":" -> Token
OpColon Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"::" -> Token
OpColonColon Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
con :: String
con -> String -> Token
QConSym String
con Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
lexer (c :: Char
c:cs :: String
cs)
| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ['A'..'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` ['a'..'z'] Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_'
= 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 "Illegal char"]
where
lexerConId :: String -> String -> [Token]
lexerConId con :: String
con (c :: Char
c:cs :: String
cs)
| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ['A'..'Z']
Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ['a'..'z']
Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ['0'..'9']
Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\''
Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_'
= String -> String -> [Token]
lexerConId (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
con) String
cs
lexerConId con :: String
con cs :: 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 var :: String
var (c :: Char
c:cs :: String
cs)
| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ['A'..'Z']
Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ['a'..'z']
Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ['0'..'9']
Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\''
Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_'
= String -> String -> [Token]
lexerVarId (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
var) String
cs
lexerVarId var :: String
var cs :: String
cs
= case ShowS
forall a. [a] -> [a]
reverse String
var of
"_" -> Token
IdUscore Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"case" -> Token
IdCase Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"class" -> Token
IdClass Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"data" -> Token
IdData Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"default" -> Token
IdDefault Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"deriving" -> Token
IdDeriving Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"do" -> Token
IdDo Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"else" -> Token
IdElse Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"forall" -> Token
IdForall Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"if" -> Token
IdIf Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"import" -> Token
IdImport Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"in" -> Token
IdIn Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"infix" -> Token
IdInfix Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"infixl" -> Token
IdInfixl Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"infixr" -> Token
IdInfixr Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"instance" -> Token
IdInstance Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"let" -> Token
IdLet Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"module" -> Token
IdModule Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"newtype" -> Token
IdNewtype Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"of" -> Token
IdOf Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"then" -> Token
IdThen Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"type" -> Token
IdType Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"where" -> Token
IdWhere Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
v :: 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 var :: String
var (c :: Char
c:cs :: String
cs)
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ':' 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 var :: String
var cs :: String
cs
= case ShowS
forall a. [a] -> [a]
reverse String
var of
".." -> Token
OpDotDot Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"=" -> Token
OpEquals Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"\\" -> Token
OpBackslash Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"|" -> Token
OpPipe Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"<-" -> Token
OpBackArrow Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"->" -> Token
OpArrow Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"@" -> Token
OpAt Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"~" -> Token
OpTilde Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
"=>" -> Token
OpImplies Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs
var :: String
var -> String -> Token
QVarSym String
var Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
lexer String
cs