module Parsers.Haskell.Common where

import Data.Foldable (Foldable (fold))


import Bookhound.Parser            (Parser, check, withTransform)
import Bookhound.ParserCombinators (IsMatch (inverse, is, isNot, noneOf, oneOf),
                                    maybeWithin, someSepBy, within, withinBoth,
                                    (->>-), (<|>), (|*), (|+), (|?))
import Bookhound.Parsers.Char      (alpha, alphaNum, char, colon, dot, lower,
                                    newLine, quote, underscore, upper)
import Bookhound.Parsers.Number    (double, int)
import Bookhound.Parsers.String    (spacing, withinDoubleQuotes, withinParens,
                                    withinQuotes)
import SyntaxTrees.Haskell.Common  (Class (..), Ctor (..), CtorOp (..),
                                    Literal (..), Module (..), QClass (QClass),
                                    QCtor (..), QCtorOp (..), QVar (..),
                                    QVarOp (..), Var (..), VarOp (..))
import Utils.Foldable              (wrapMaybe)
import Utils.String                (wrap, wrapBackQuotes, wrapQuotes)



literal :: Parser Literal
literal :: Parser Literal
literal = forall a. Parser a -> Parser a
token forall a b. (a -> b) -> a -> b
$
      Literal
UnitLit forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a. IsMatch a => a -> Parser a
is String
"()"
  forall a. Parser a -> Parser a -> Parser a
<|> Bool -> Literal
BoolLit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a. IsMatch a => a -> Parser a
is String
"True" forall a. Parser a -> Parser a -> Parser a
<|> Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a. IsMatch a => a -> Parser a
is String
"False")
  forall a. Parser a -> Parser a -> Parser a
<|> String -> Literal
IntLit   forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer
int
  forall a. Parser a -> Parser a -> Parser a
<|> String -> Literal
FloatLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Double
double
  forall a. Parser a -> Parser a -> Parser a
<|> Char -> Literal
CharLit   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser a
withinQuotes        (Parser Char
charLit   forall a. Parser a -> Parser a -> Parser a
<|> Parser Char
charLitEscaped)
  forall a. Parser a -> Parser a -> Parser a
<|> String -> Literal
StringLit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser a
withinDoubleQuotes ((Parser Char
stringLit forall a. Parser a -> Parser a -> Parser a
<|> Parser Char
charLitEscaped) |*)

  where
    charLit :: Parser Char
charLit = forall a. IsMatch a => [a] -> Parser a
noneOf [Char
'\'', Char
'\\']
    charLitEscaped :: Parser Char
charLitEscaped = forall a. Read a => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
wrapQuotes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. IsMatch a => a -> Parser a
is Char
'\\' forall a b.
(ToString a, ToString b) =>
Parser a -> Parser b -> Parser String
->>- Parser Char
alpha)
                     forall a. Parser a -> Parser a -> Parser a
<|> (forall a. IsMatch a => a -> Parser a
is Char
'\\' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char
char)
    stringLit :: Parser Char
stringLit = forall a. IsMatch a => [a] -> Parser a
noneOf [Char
'"', Char
'\\']



var :: Parser Var
var :: Parser Var
var = String -> Var
Var forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String -> Parser String
notReserved
              (forall a. Parser a -> Parser a
withinParens (Parser Char -> Parser String
operator Parser Char
opSymbol forall a. Parser a -> Parser a -> Parser a
<|> Parser String
simpleOperator forall a. Parser a -> Parser a -> Parser a
<|> Parser String
simpleOperatorFn)
               forall a. Parser a -> Parser a -> Parser a
<|> Parser Char -> Parser String
ident Parser Char
lower)

ctor :: Parser Ctor
ctor :: Parser Ctor
ctor = String -> Ctor
Ctor forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String -> Parser String
notReserved
                (forall a. Parser a -> Parser a
withinParens (Parser Char -> Parser String
operator Parser Char
colon) forall a. Parser a -> Parser a -> Parser a
<|> Parser Char -> Parser String
ident Parser Char
upper)

varOp :: Parser VarOp
varOp :: Parser VarOp
varOp = String -> VarOp
VarOp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String -> Parser String
notReserved
                 (String -> String
wrapBackQuotes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser a
withinBackQuotes (Parser Char -> Parser String
ident Parser Char
lower)
                  forall a. Parser a -> Parser a -> Parser a
<|> (Parser Char -> Parser String
operator Parser Char
opSymbol forall a. Parser a -> Parser a -> Parser a
<|> Parser String
simpleOperator))

ctorOp :: Parser CtorOp
ctorOp :: Parser CtorOp
ctorOp = String -> CtorOp
CtorOp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String -> Parser String
notReserved
                    (String -> String
wrapBackQuotes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser a
withinBackQuotes (Parser Char -> Parser String
ident Parser Char
upper)
                     forall a. Parser a -> Parser a -> Parser a
<|> Parser Char -> Parser String
operator Parser Char
colon)

class' :: Parser Class
class' :: Parser Class
class' = String -> Class
Class forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char -> Parser String
ident Parser Char
upper

module' :: Parser Module
module' :: Parser Module
module' = [String] -> Module
Module forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. Parser a -> Parser b -> Parser [b]
someSepBy Parser Char
dot (Parser Char -> Parser String
ident Parser Char
upper)

module'' :: Parser Module
module'' :: Parser Module
module'' = [String] -> Module
Module forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. Parser a -> Parser b -> Parser [b]
someSepBy Parser Char
dot (Parser Char -> Parser String
nonTokenIdent Parser Char
upper)

qVar :: Parser QVar
qVar :: Parser QVar
qVar = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe Module -> Var -> QVar
QVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser (Maybe Module, a)
qTerm Parser Var
var

qCtor :: Parser QCtor
qCtor :: Parser QCtor
qCtor = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe Module -> Ctor -> QCtor
QCtor forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b. (String -> b) -> Parser (Maybe Module, b)
qTerm' String -> Ctor
Ctor

qVarOp :: Parser QVarOp
qVarOp :: Parser QVarOp
qVarOp = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe Module -> VarOp -> QVarOp
QVarOp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser (Maybe Module, a)
qTerm Parser VarOp
varOp

qCtorOp :: Parser QCtorOp
qCtorOp :: Parser QCtorOp
qCtorOp = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe Module -> CtorOp -> QCtorOp
QCtorOp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser (Maybe Module, a)
qTerm Parser CtorOp
ctorOp

qClass :: Parser QClass
qClass :: Parser QClass
qClass = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe Module -> Class -> QClass
QClass forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b. (String -> b) -> Parser (Maybe Module, b)
qTerm' String -> Class
Class



ident :: Parser Char -> Parser String
ident :: Parser Char -> Parser String
ident Parser Char
start = forall a. Parser a -> Parser a
token forall a b. (a -> b) -> a -> b
$ (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char
start forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser Char
idChar |*)

operator :: Parser Char -> Parser String
operator :: Parser Char -> Parser String
operator Parser Char
start = forall a. Parser a -> Parser a
token forall a b. (a -> b) -> a -> b
$ (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char
start
                             forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Parser Char
opSymbol forall a. Parser a -> Parser a -> Parser a
<|> Parser Char
colon) |*)

simpleOperator :: Parser String
simpleOperator :: Parser String
simpleOperator = forall a. Parser a -> Parser a
token forall a b. (a -> b) -> a -> b
$ forall a. IsMatch a => [a] -> Parser a
oneOf [String
":"]

simpleOperatorFn :: Parser String
simpleOperatorFn :: Parser String
simpleOperatorFn = forall a. Parser a -> Parser a
token forall a b. (a -> b) -> a -> b
$ forall a. IsMatch a => [a] -> Parser a
oneOf [String
",", String
",,", String
",,,"]

nonTokenQVar :: Parser QVar
nonTokenQVar :: Parser QVar
nonTokenQVar = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe Module -> Var -> QVar
QVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser (Maybe Module, a)
qTerm Parser Var
x
  where  x :: Parser Var
x = String -> Var
Var forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. String -> (a -> Bool) -> Parser a -> Parser a
check String
"" (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
reservedKeyWords)
                    (Parser Char -> Parser String
nonTokenIdent Parser Char
lower)

nonTokenIdent :: Parser Char -> Parser String
nonTokenIdent :: Parser Char -> Parser String
nonTokenIdent Parser Char
start = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char
start forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser Char
idChar |*)


idChar :: Parser Char
idChar :: Parser Char
idChar = Parser Char
alphaNum forall a. Parser a -> Parser a -> Parser a
<|> Parser Char
underscore forall a. Parser a -> Parser a -> Parser a
<|> Parser Char
quote

opSymbol :: Parser Char
opSymbol :: Parser Char
opSymbol = forall a. IsMatch a => [a] -> Parser a
oneOf String
symbolChars

token :: Parser a -> Parser a
token :: forall a. Parser a -> Parser a
token = forall a. (forall a. Parser a -> Parser a) -> Parser a -> Parser a
withTransform forall a b. (a -> b) -> a -> b
$ forall a b. Parser a -> Parser b -> Parser b
maybeWithin (Parser String
anyComment |+) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Parser a -> Parser b -> Parser b
maybeWithin Parser String
spacing


qTerm :: Parser a -> Parser (Maybe Module, a)
qTerm :: forall a. Parser a -> Parser (Maybe Module, a)
qTerm Parser a
x =  (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Parser Module
module'' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Char
dot) |?) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
x


qTerm' :: (String -> b) -> Parser (Maybe Module, b)
qTerm' :: forall b. (String -> b) -> Parser (Maybe Module, b)
qTerm' String -> b
fn = forall a. Parser a -> Parser a
token Parser (Maybe Module, b)
parser
  where
    parser :: Parser (Maybe Module, b)
parser = do [String]
xs <- Module -> [String]
getComponents forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Module
module''
                pure $ ([String] -> Module
Module forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> Maybe (t a)
wrapMaybe (forall a. [a] -> [a]
init [String]
xs), String -> b
fn forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [String]
xs)
    getComponents :: Module -> [String]
getComponents (Module [String]
xs) = [String]
xs


anyComment :: Parser String
anyComment :: Parser String
anyComment = Parser String
pragma forall a. Parser a -> Parser a -> Parser a
<|> Parser String
blockComment forall a. Parser a -> Parser a -> Parser a
<|> Parser String
lineComment

lineComment :: Parser String
lineComment :: Parser String
lineComment = forall a. IsMatch a => a -> Parser a
is String
"--" forall a b.
(ToString a, ToString b) =>
Parser a -> Parser b -> Parser String
->>- (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char
newLine forall a. Parser a -> Parser a -> Parser a
<|>
                          forall a. IsMatch a => [a] -> Parser a
noneOf String
symbolChars forall a b.
(ToString a, ToString b) =>
Parser a -> Parser b -> Parser String
->>- (forall a. IsMatch a => Parser a -> Parser a
inverse Parser Char
newLine |*))


blockComment :: Parser String
blockComment :: Parser String
blockComment = String -> String -> String -> String
wrap String
"{-"  String
"-}" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b c. Parser a -> Parser b -> Parser c -> Parser c
withinBoth (forall a. IsMatch a => a -> Parser a
is String
"{-") (forall a. IsMatch a => a -> Parser a
is String
"-}")
                         ((:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. IsMatch a => a -> Parser a
isNot String
"#") forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((forall a. IsMatch a => a -> Parser a
isNot String
"-" forall a b.
(ToString a, ToString b) =>
Parser a -> Parser b -> Parser String
->>- forall a. IsMatch a => a -> Parser a
isNot String
"}") |*))


pragma :: Parser String
pragma :: Parser String
pragma = String -> String -> String -> String
wrap String
"{-#"  String
"#-}" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b c. Parser a -> Parser b -> Parser c -> Parser c
withinBoth (forall a. IsMatch a => a -> Parser a
is String
"{-#") (forall a. IsMatch a => a -> Parser a
is String
"#-}")
                             ((forall a. IsMatch a => a -> Parser a
isNot String
"#" |*))

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


notReserved :: Parser String -> Parser String
notReserved :: Parser String -> Parser String
notReserved = forall a. String -> (a -> Bool) -> Parser a -> Parser a
check String
"reserved"
               (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ([String]
reservedSymbols forall a. [a] -> [a] -> [a]
++ [String]
reservedKeyWords))


reservedKeyWords :: [String]
reservedKeyWords :: [String]
reservedKeyWords = [String
"case",String
"class",String
"data",String
"default",String
"deriving",
                    String
"do",String
"else",String
"forall" ,String
"if",String
"import",String
"in",
                    String
"infix",String
"infixl",String
"infixr",String
"instance",
                    String
"let",String
"module" ,String
"newtype",String
"of",String
"qualified",
                    String
"then",String
"type",String
"where",String
"_" ,String
"foreign",
                    String
"ccall",String
"as",String
"safe",String
"unsafe"]

reservedSymbols :: [String]
reservedSymbols :: [String]
reservedSymbols = [String
"..",String
"::",String
"=",String
"\\",String
"|",String
"<-",String
"->",String
"@",String
"~",String
"=>",String
"[",String
"]"]


withinBackQuotes :: Parser b -> Parser b
withinBackQuotes :: forall a. Parser a -> Parser a
withinBackQuotes = forall a b. Parser a -> Parser b -> Parser b
within (forall a. IsMatch a => a -> Parser a
is Char
'`')