Implement various matchable features
[L-seed.git] / src / Lseed / Grammar / Parse.hs
1 module Lseed.Grammar.Parse ( parseGrammar ) where
2
3 import Text.Parsec
4 import qualified Text.Parsec.Token as P
5 import Text.Parsec.Language (javaStyle)
6 import Text.Parsec.Expr
7 import Control.Monad
8
9 import Lseed.Grammar
10
11 -- The lexer
12 lexer       = P.makeTokenParser $ javaStyle
13         { P.reservedNames = ["RULE", "WHEN", "Tag", "Light", "Branch", "At",
14                              "Length", "Light", "Sublength", "Sublight", "Direction", "Angle",
15                              "BY", "TO", "IMPORTANCE", "WEIGHT"]
16         }
17
18 parens      = P.parens lexer
19 braces      = P.braces lexer
20 identifier  = P.identifier lexer
21 reserved    = P.reserved lexer
22 reservedOp  = P.reservedOp lexer
23 natural     = P.natural lexer
24 integer     = P.integer lexer
25 stringLiteral = P.stringLiteral lexer
26 naturalOrFloat = P.naturalOrFloat lexer
27 float       = P.float lexer
28 comma       = P.comma lexer
29 whiteSpace  = P.whiteSpace lexer
30
31 -- Expression
32
33 -- The parser
34
35 parseGrammar :: String -> String -> Either ParseError GrammarFile
36 parseGrammar = parse pFile
37
38 type Parser = Parsec String ()
39
40 pFile :: Parser GrammarFile
41 pFile = whiteSpace >> many1 pRule
42
43 pRule :: Parser GrammarRule
44 pRule = do
45         reserved "RULE" 
46         name <- pString
47         condition <- option (Always True) $ do
48                 reserved "WHEN"
49                 pCondition
50         actions <- many1 pAction
51         maybe (return ()) fail (actionsAreInvalid actions)
52         priority <- option 1 $ do
53                 reserved "IMPORTANCE"
54                 fromIntegral `fmap` natural
55         weight <- option 1 $ do
56                 reserved "WEIGHT"
57                 fromIntegral `fmap` natural
58         skipMany nl
59         return $ GrammarRule name priority weight condition actions
60
61 pCondition :: Parser Condition
62 pCondition = buildExpressionParser table term
63   where term = parens pCondition <|> pNumCond <|> pTagTest
64         table = [[ Infix (do{ reserved "AND"; return And }) AssocLeft ]
65                 ,[Infix (do{ reserved "OR";  return Or  }) AssocLeft ]
66                 ]
67 pNumCond = do
68         what <- pMatchable
69         cmp <- pCmp
70         value <- pFloat
71         return (NumCond what cmp value) 
72
73 pTagTest = do
74         reserved "TAG"
75         reservedOp "="
76         value <- pString
77         return (UserTagIs value)
78
79 pAction :: Parser GrammarAction
80 pAction = pBranch <|> pGrow
81
82 pBranch :: Parser GrammarAction
83 pBranch = do
84         reserved "BRANCH"
85         reserved "AT"
86         fraction <- pFloat
87         unless (0 <= fraction && fraction <= 100) $
88                 fail "Fork position has to be in between 0% and 100%."
89         reservedOp "%"
90         reserved "ANGLE"
91         reservedOp "="
92         angle <- pFloat
93         comma
94         reserved "LENGTH"
95         reservedOp "="
96         length <- pFloat
97         mTag <- optionMaybe $ do
98                 comma
99                 reserved "TAG"
100                 reservedOp "="
101                 pString
102         return (AddBranch (fraction/100) angle length mTag)
103
104 pGrow :: Parser GrammarAction
105 pGrow = do
106         reserved "GROW"
107         desc <- by <|> to
108         return (SetLength desc Nothing)
109   where by = do
110                 reserved "BY"
111                 value <- pFloat
112                 (reservedOp "%" >> return (AdditionalRelative value)) <|>
113                                    return (Additional value)
114         to = do
115                 reserved "TO"
116                 value <- pFloat
117                 return (Absolute value)
118                 
119
120 pMatchable =
121         choice $ map (\(a,b) -> const b `fmap` reserved a) $
122                 [ ("LIGHT", MatchLight)
123                 , ("LENGTH", MatchLength)
124                 , ("SUBLENGTH", MatchSubLength)
125                 , ("SUBLIGHT", MatchSubLight)
126                 , ("ANGLE", MatchAngle)
127                 , ("DIRECTION", MatchDirection)
128                 ]
129
130 pCmp = 
131         choice $ map (\(a,b) -> const b `fmap` reservedOp a) $
132                 [ ("<=", LE)
133                 , ("<",  Less)
134                 , ("=",  Equals)
135                 , (">",  Greater)
136                 , (">=", GE)
137                 ]
138
139 pString = identifier <|> stringLiteral
140
141 pFloat = do value <- try (do 
142                         i <- fromIntegral `fmap` integer
143                         notFollowedBy (char '.')
144                         return i
145                      )  <|> float
146             (deg >> return (value / 180 * pi)) <|> return value
147
148 deg = reservedOp "\194\176"
149         
150 nl = char '\n'