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
= 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
= 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
= 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
'`')