module Sindre.Parser( parseSindre
, parseInteger
)
where
import Sindre.Sindre hiding (SourcePos, position, string)
import qualified Sindre.Sindre as Sindre
import System.Console.GetOpt
import Text.Parsec hiding ((<|>), many, optional)
import Text.Parsec.Expr
import Text.Parsec.String
import Text.Parsec.Token (LanguageDef, GenLanguageDef(..))
import qualified Text.Parsec.Token as P
import Control.Applicative
import Control.Monad.Identity
import Data.Char hiding (Control)
import Data.Function
import Data.List hiding (insert)
import Data.Maybe
import qualified Data.Map as M
import qualified Data.Set as S
parseSindre :: Program -> SourceName -> String -> Either ParseError Program
parseSindre prog = parse (P.whiteSpace lexer *> sindre prog)
parseInteger :: String -> Maybe Double
parseInteger = either (const Nothing) Just .
parse (decimal <* eof) ""
data Directive = GUIDirective (Maybe (P Expr), GUI)
| ActionDirective (Pattern, Action)
| GlobalDirective (Identifier, P Expr)
| FuncDirective (Identifier, Function)
| OptDirective (Identifier, (SindreOption, Maybe Value))
| BeginDirective [P Stmt]
definedBy :: [Directive] -> S.Set Identifier
definedBy = foldr f S.empty
where f (GlobalDirective (k, _)) = S.insert k
f (OptDirective (k, _)) = S.insert k
f _ = id
getGUI :: [Directive] -> Either String (Maybe (Maybe (P Expr), GUI))
getGUI ds = case foldl f [] ds of
[gui'] -> Right $ Just gui'
[] -> Right Nothing
_ -> Left "Multiple GUI definitions"
where f l (GUIDirective x) = x:l
f l _ = l
getActions :: [P Directive] -> [P (Pattern, Action)]
getActions = foldl f []
where f l (P p (ActionDirective x)) = P p x:l
f l _ = l
getGlobals :: [P Directive] -> [P (Identifier, P Expr)]
getGlobals = foldl f []
where f m (P p (GlobalDirective x)) = P p x:m
f m _ = m
getFunctions :: [P Directive] -> [P (Identifier, Function)]
getFunctions = foldl f []
where f m (P p (FuncDirective x)) = P p x:m
f m _ = m
getOptions :: [P Directive] -> [P (Identifier, (SindreOption, Maybe Value))]
getOptions = foldl f []
where f m (P p (OptDirective x)) = P p x:m
f m _ = m
getBegin :: [Directive] -> [P Stmt]
getBegin = foldl f []
where f m (BeginDirective x) = m++x
f m _ = m
applyDirectives :: [P Directive] -> Program -> Either String Program
applyDirectives ds prog = do
let prog' = prog {
programActions = getActions ds ++ programActions prog
, programGlobals = globals' ++ getGlobals ds
, programFunctions =
merge (getFunctions ds) (programFunctions prog)
, programOptions = options' ++ getOptions ds
, programBegin = getBegin ds' ++ programBegin prog
}
maybe prog' (\gui' -> prog' { programGUI = gui' }) <$> getGUI ds'
where options' = filter (not . hasNewDef . fst . unP) (programOptions prog)
globals' = filter (not . hasNewDef . fst . unP) (programGlobals prog)
hasNewDef k = S.member k $ definedBy ds'
merge = unionBy ((==) `on` fst . unP)
ds' = map unP ds
position :: Parser (String, Int, Int)
position = do pos <- getPosition
pure (sourceName pos, sourceLine pos, sourceColumn pos)
node :: Parser a -> Parser (P a)
node p = pure P <*> position <*> p
sindre :: Program -> Parser Program
sindre prog = do ds <- reverse <$> many directive <* eof
either fail return $ applyDirectives ds prog
directive :: Parser (P Directive)
directive = directive' <* skipMany semi
where directive' = node $
BeginDirective <$> begindef
<|> ActionDirective <$> reaction
<|> GUIDirective <$> gui
<|> GlobalDirective <$> constdef
<|> FuncDirective <$> functiondef
<|> OptDirective <$> optiondef
gui :: Parser (Maybe (P Expr), GUI)
gui = reserved "GUI" *> braces gui'
<?> "GUI definition"
where gui' = do
name' <- optional name
clss <- node className
args' <- M.fromList <$> args <|> pure M.empty
orient' <- optional orient
children' <- children <|> pure []
return (orient',
GUI { widgetName = name'
, widgetClass = clss
, widgetArgs = args'
, widgetChildren = children'
})
name = varName <* reservedOp "="
args = parens $ commaSep arg
arg = pure (,) <*> varName <* reservedOp "=" <*> expression
children = braces $ many (gui' <* skipMany semi)
orient = reservedOp "@" *> expression
functiondef :: Parser (Identifier, Function)
functiondef = reserved "function" *> pure (,)
<*> try varName <*> function
<?> "function definition"
where function = pure Function
<*> parens (commaSep varName)
<*> braces statements
optiondef :: Parser (Identifier, (SindreOption, Maybe Value))
optiondef = reserved "option" *> do
var <- varName
pure ((,) var) <*> parens (option' var)
<?> "option definition"
where option' var = do
s <- optional shortopt <* optional comma
l <- optional longopt <* optional comma
odesc <- optional optdesc <* optional comma
adesc <- optional argdesc <* optional comma
defval <- optional literal
let (s', l') = (maybeToList s, maybeToList l)
let noargfun = NoArg $ M.insert var "true"
let argfun = ReqArg $ \arg -> M.insert var arg
return (Option s' l'
(maybe noargfun argfun adesc)
(fromMaybe "" odesc)
, defval)
shortopt = try $ lexeme $ char '-' *> alphaNum
longopt = string "--" *> identifier
optdesc = stringLiteral
argdesc = stringLiteral
begindef :: Parser [P Stmt]
begindef = reserved "BEGIN" *> braces statements
reaction :: Parser (Pattern, Action)
reaction = pure (,) <*> try pattern <*> action <?> "action"
constdef :: Parser (Identifier, P Expr)
constdef = pure (,) <*> try varName <* reservedOp "=" <*> expression
pattern :: Parser Pattern
pattern = simplepat `chainl1` (reservedOp "||" *> pure OrPattern)
where simplepat =
pure ChordPattern <*>
(reservedOp "<" *> chord <* reservedOp ">")
<|> pure SourcedPattern
<*> source <* string "->"
<*> varName
<*> parens (commaSep varName)
source :: Parser SourcePat
source = pure NamedSource <*> varName <*> field
<|> pure GenericSource
<*> (char '$' *> className) <*> parens varName <*> field
where field = optional $ char '.' *> varName
action :: Parser Action
action = StmtAction <$> braces statements
key :: Parser Key
key = do s <- identifier
case s of [c] -> return $ CharKey c
"Space" -> return $ CharKey ' '
_ -> return $ CtrlKey s
modifier :: Parser KeyModifier
modifier = string "C" *> return Control
<|> string "M" *> return Meta
<|> string "Shift" *> return Shift
<|> string "S" *> return Super
<|> string "H" *> return Hyper
chord :: Parser Chord
chord = pure (,) <*> (S.fromList <$> many (try modifier <* char '-')) <*> key
statements :: Parser [P Stmt]
statements = many (statement <* skipMany semi) <?> "statement"
statement :: Parser (P Stmt)
statement = node $
printstmt
<|> quitstmt
<|> returnstmt
<|> (reserved "next" *> pure Next)
<|> (reserved "continue" *> pure Continue)
<|> (reserved "break" *> pure Break)
<|> ifstmt
<|> whilestmt
<|> forstmt
<|> dostmt
<|> focusstmt
<|> Expr <$> expression
where printstmt = reserved "print" *>
(Print <$> commaSep expression)
quitstmt = reserved "exit" *>
(Exit <$> optional expression)
returnstmt = reserved "return" *>
(Return <$> optional expression)
ifstmt = (reserved "if" *> pure If)
<*> parens expression
<*> braces statements
<*> ( reserved "else" *>
((:[]) <$> node ifstmt <|> braces statements)
<|> return [])
whilestmt = (reserved "while" *> pure While)
<*> parens expression
<*> braces statements
forstmt = reserved "for" *> parens
(pure For <*> expression <* semi
<*> expression <* semi
<*> expression)
<*> braces statements
dostmt = (reserved "do" *> pure Do)
<*> braces statements
<*> (reserved "while" *> parens expression)
focusstmt = reserved "focus" *> (Focus <$> expression)
keywords :: [String]
keywords = ["if", "else", "while", "for", "do",
"function", "return", "continue", "break",
"exit", "print", "GUI", "option"]
sindrelang :: LanguageDef ()
sindrelang = LanguageDef {
commentStart = "/*"
, commentEnd = "*/"
, commentLine = "//"
, nestedComments = True
, identStart = letter
, identLetter = alphaNum <|> char '_'
, opStart = oneOf "+-/*&|;,<>"
, opLetter = oneOf "=+-|&"
, reservedNames = keywords
, reservedOpNames = [ "++", "--"
, "^", "**"
, "+", "-", "/", "*", "%"
, "&&", "||", ";", ","
, "<", ">", "<=", ">=", "!="
, "=", "*=", "/=", "+=", "-="
, "%=", "^="
, "?", ":"]
, caseSensitive = True
}
exprOperators :: OperatorTable String () Identity (P Expr)
compOperators :: OperatorTable String () Identity (P Expr)
assignOperators :: OperatorTable String () Identity (P Expr)
(exprOperators, compOperators, assignOperators) =
( [ [ prefix "++" $
preop Plus (Literal $ Number 1)
, postfix "++" PostInc
, prefix "--" $
preop Plus (Literal $ Number $ 1)
, postfix "--" PostDec
, Postfix $ do p <- position
brackets $ do
idx <- expression
pure (\e -> P p $ e `Lookup` idx)]
, [ binary "**" RaisedTo AssocRight
, binary "^" RaisedTo AssocRight ]
, [ prefix "-" $ \e -> Times (Literal (Number $ 1) `at` e) e
, prefix "+" $ \(P _ e) -> e
, prefix "!" Not ]
, [ binary "*" Times AssocLeft,
binary "/" Divided AssocLeft, binary "%" Modulo AssocLeft ]
, [ binary "+" Plus AssocLeft, binary "-" Minus AssocLeft ]]
, [ [ binary "==" Equal AssocNone
, binary "<" LessThan AssocNone
, binary ">" (flip LessThan) AssocNone
, binary "<=" LessEql AssocNone
, binary ">=" (flip LessEql) AssocNone
, binary "!=" (\e1 e2 -> Not $ Equal e1 e2 `at` e1) AssocNone ]
, [ binary "&&" (\x y -> Cond x y $ Literal falsity `at` x) AssocRight ]
, [ binary "||" (\x y -> Cond x (Literal truth `at` x) y) AssocRight ]]
, [ [ binary "=" Assign AssocRight
, binary "*=" (inplace Times) AssocLeft
, binary "/=" (inplace Divided) AssocLeft
, binary "+=" (inplace Plus) AssocLeft
, binary "-=" (inplace Minus) AssocLeft
, binary "%=" (inplace Modulo) AssocLeft
, binary "^=" (inplace RaisedTo) AssocLeft]])
where binary name fun = Infix $ do
p <- position
reservedOp name
pure (\e1 e2 -> P p $ fun e1 e2)
unary name fun = do p <- position
reservedOp name
pure $ P p . fun
prefix name fun = Prefix $ unary name fun
postfix name fun = Postfix $ unary name fun
inplace op e1@(P pos _) e2 = e1 `Assign` P pos (e1 `op` e2)
preop op e1 e2@(P pos _) = e2 `Assign` P pos (e2 `op` P pos e1)
expression :: Parser (P Expr)
expression = try condexp <|> expr1 <?> "expression"
where condexp = node $ pure Cond <*> expr2 <* reservedOp "?"
<*> expression <* reservedOp ":"
<*> expression
expr1 = buildExpressionParser assignOperators $
try condexp <|> expr2
expr2 = buildExpressionParser compOperators $
expr3 `chainl1` pure (\x y -> Concat x y `at` x)
expr3 = buildExpressionParser exprOperators $
try atomic <|> compound
atomic :: Parser (P Expr)
atomic = parens expression
<|> node (Literal <$> literal)
literal :: Parser Value
literal = pure Number <*> decimal
<|> pure Sindre.string <*> stringLiteral
<|> boolean
<|> dict
<?> "literal value"
boolean :: Parser Value
boolean = lexeme (string "true") *> return truth
<|> lexeme (string "false") *> return falsity
dict :: Parser Value
dict = lexeme (string "[]") *> return (Dict M.empty)
compound :: Parser (P Expr)
compound =
field' `chainl1` (char '.' *> pure comb)
where comb e (P _ (Var v)) = FieldOf v e `at` e
comb e (P _ (Funcall v es)) = Methcall e v es `at` e
comb _ _ = undefined
field' = try fcall <|> node (Var <$> varName)
lexer :: P.TokenParser ()
lexer = P.makeTokenParser sindrelang
lexeme :: Parser a -> Parser a
lexeme = P.lexeme lexer
comma :: Parser String
comma = P.comma lexer
commaSep :: Parser a -> Parser [a]
commaSep = P.commaSep lexer
semi :: Parser String
semi = P.semi lexer
parens :: Parser a -> Parser a
parens = P.parens lexer
braces :: Parser a -> Parser a
braces = P.braces lexer
brackets :: Parser a -> Parser a
brackets = P.brackets lexer
fcall :: Parser (P Expr)
fcall = node $ pure Funcall <*> varName <*>
parens (sepBy expression comma)
check :: (a -> Bool) -> a -> Parser a
check f x | f x = return x
check _ _ = fail "Failed check"
isClassName :: String -> Bool
isClassName "" = False
isClassName s@(c:_) = not (all isUpper s) && isUpper c
className :: Parser String
className = try (check isClassName =<< identifier) <?> "class"
varName :: Parser String
varName = try (check (not . isClassName) =<< identifier) <?> "variable"
identifier :: Parser String
identifier = P.identifier lexer
decimal :: Parser Double
decimal = either fromIntegral id <$> P.naturalOrFloat lexer
stringLiteral :: Parser String
stringLiteral = P.stringLiteral lexer
reservedOp :: String -> Parser ()
reservedOp = P.reservedOp lexer
reserved :: String -> Parser ()
reserved = P.reserved lexer