module Lseed.Grammar.Parse ( parseGrammar ) where
import Text.Parsec
import qualified Text.Parsec.Token as P
import Text.Parsec.Language (javaStyle)
import Text.Parsec.Expr
import Control.Monad
import Lseed.Data
lexer = P.makeTokenParser $ javaStyle
{ P.reservedNames = ["RULE", "WHEN", "SET", "Tag", "Light", "Branch", "At",
"Length", "Light", "Sublength", "Sublight", "Direction", "Angle",
"BY", "TO", "PRIORITY", "WEIGHT", "Blossom"]
}
parens = P.parens lexer
braces = P.braces lexer
identifier = P.identifier lexer
reserved = P.reserved lexer
reservedOp = P.reservedOp lexer
natural = P.natural lexer
integer = P.integer lexer
stringLiteral = P.stringLiteral lexer
naturalOrFloat = P.naturalOrFloat lexer
float = P.float lexer
comma = P.comma lexer
whiteSpace = P.whiteSpace lexer
parseGrammar :: String -> String -> Either ParseError GrammarFile
parseGrammar = parse pFile
type Parser = Parsec String ()
pFile :: Parser GrammarFile
pFile = do
whiteSpace
gf <- many1 pRule
eof
return gf
pRule :: Parser GrammarRule
pRule = do
reserved "RULE"
name <- pString
condition <- option (Always True) $ do
reserved "WHEN"
pCondition
action <- pAction
priority <- option 1 $ do
reserved "PRIORITY"
fromIntegral `fmap` natural
weight <- option 1 $ do
reserved "WEIGHT"
fromIntegral `fmap` natural
return $ GrammarRule name priority weight condition action
pCondition :: Parser Condition
pCondition = buildExpressionParser table term
where term = parens pCondition <|> pNumCond <|> pTagTest
table = [[ Infix (do{ reserved "AND"; return And }) AssocLeft ]
,[Infix (do{ reserved "OR"; return Or }) AssocLeft ]
]
pNumCond = do
what <- pMatchable
cmp <- pCmp
value <- pFloat
return (NumCond what cmp value)
pTagTest = do
reserved "TAG"
reservedOp "="
value <- pString
return (UserTagIs value)
pAction :: Parser GrammarAction
pAction = pBranch <|> pGrow <|> pBlossom
pBranch :: Parser GrammarAction
pBranch = do
reserved "BRANCH"
fraction <- (do
reserved "AT"
fraction <- pFloat
unless (0 <= fraction && fraction <= 100) $
fail "Fork position has to be in between 0% and 100%."
reservedOp "%"
return fraction
) <|> (return 100)
branches <- many1 $ do
reserved "ANGLE"
reservedOp "="
angle <- pFloat
comma
reserved "LENGTH"
reservedOp "="
length <- pFloat
mTag <- optionMaybe $ do
comma
reserved "TAG"
reservedOp "="
pString
return (angle, length, mTag)
mTag <- pSetTag
return (AddBranches mTag (fraction/100) branches)
pGrow :: Parser GrammarAction
pGrow = do
reserved "GROW"
desc <- by <|> to
mTag <- pSetTag
return (SetLength mTag desc)
where by = do
reserved "BY"
value <- pFloat
(reservedOp "%" >> return (AdditionalRelative value)) <|>
return (Additional value)
to = do
reserved "TO"
value <- pFloat
return (Absolute value)
pBlossom :: Parser GrammarAction
pBlossom = do
reserved "BLOSSOM"
mTag <- pSetTag
return (Blossom mTag)
pSetTag :: Parser (Maybe UserTag)
pSetTag = optionMaybe $ do
reserved "SET"
reserved "TAG"
reservedOp "="
pString
pMatchable =
choice $ map (\(a,b) -> const b `fmap` reserved a) $
[ ("LIGHT", MatchLight)
, ("LENGTH", MatchLength)
, ("SUBLENGTH", MatchSubLength)
, ("SUBLIGHT", MatchSubLight)
, ("ANGLE", MatchAngle)
, ("DIRECTION", MatchDirection)
]
pCmp =
choice $ map (\(a,b) -> const b `fmap` reservedOp a) $
[ ("<=", LE)
, ("<", Less)
, ("=", Equals)
, (">", Greater)
, (">=", GE)
]
pString = identifier <|> stringLiteral
pFloat = do value <- try (do
i <- fromIntegral `fmap` integer
notFollowedBy (char '.')
return i
) <|> float
(deg >> return (value / 180 * pi)) <|> return value
deg = reservedOp "\194\176"