b0cd6732d3a5b20692567801551cb056bc6c5d8f
[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.Data
10
11 -- The lexer
12 lexer       = P.makeTokenParser $ javaStyle
13         { P.reservedNames = ["RULE", "WHEN", "SET", "Tag", "Light", "Branch", "At",
14                              "Length", "Light", "Sublength", "Sublight", "Direction", "Angle",
15                              "BY", "TO", "IMPORTANCE", "WEIGHT", "Blossom"]
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 = do
42         whiteSpace 
43         gf <- many1 pRule
44         eof
45         return gf
46
47 pRule :: Parser GrammarRule
48 pRule = do
49         reserved "RULE" 
50         name <- pString
51         condition <- option (Always True) $ do
52                 reserved "WHEN"
53                 pCondition
54         action <- pAction
55         -- maybe (return ()) fail (actionIsInvalid action)
56         priority <- option 1 $ do
57                 reserved "IMPORTANCE"
58                 fromIntegral `fmap` natural
59         weight <- option 1 $ do
60                 reserved "WEIGHT"
61                 fromIntegral `fmap` natural
62         return $ GrammarRule name priority weight condition action
63
64 pCondition :: Parser Condition
65 pCondition = buildExpressionParser table term
66   where term = parens pCondition <|> pNumCond <|> pTagTest
67         table = [[ Infix (do{ reserved "AND"; return And }) AssocLeft ]
68                 ,[Infix (do{ reserved "OR";  return Or  }) AssocLeft ]
69                 ]
70 pNumCond = do
71         what <- pMatchable
72         cmp <- pCmp
73         value <- pFloat
74         return (NumCond what cmp value) 
75
76 pTagTest = do
77         reserved "TAG"
78         reservedOp "="
79         value <- pString
80         return (UserTagIs value)
81
82 pAction :: Parser GrammarAction
83 pAction = pBranch <|> pGrow <|> pBlossom
84
85 pBranch :: Parser GrammarAction
86 pBranch = do
87         reserved "BRANCH"
88         fraction <- (do
89                 reserved "AT"
90                 fraction <- pFloat
91                 unless (0 <= fraction && fraction <= 100) $
92                         fail "Fork position has to be in between 0% and 100%."
93                 reservedOp "%"
94                 return fraction
95                 ) <|> (return 100)
96         branches <- many1 $ do
97                 reserved "ANGLE"
98                 reservedOp "="
99                 angle <- pFloat
100                 comma
101                 reserved "LENGTH"
102                 reservedOp "="
103                 length <- pFloat
104                 mTag <- optionMaybe $ do
105                         comma
106                         reserved "TAG"
107                         reservedOp "="
108                         pString
109                 return (angle, length, mTag)
110         mTag <- pSetTag
111         return (AddBranches mTag (fraction/100) branches)
112
113 pGrow :: Parser GrammarAction
114 pGrow = do
115         reserved "GROW"
116         desc <- by <|> to
117         mTag <- pSetTag
118         return (SetLength mTag desc)
119   where by = do
120                 reserved "BY"
121                 value <- pFloat
122                 (reservedOp "%" >> return (AdditionalRelative value)) <|>
123                                    return (Additional value)
124         to = do
125                 reserved "TO"
126                 value <- pFloat
127                 return (Absolute value)
128
129 pBlossom :: Parser GrammarAction
130 pBlossom = do
131         reserved "BLOSSOM"
132         mTag <- pSetTag
133         return (Blossom mTag)
134
135 pSetTag :: Parser (Maybe UserTag)
136 pSetTag = optionMaybe $ do
137                 reserved "SET"
138                 reserved "TAG"
139                 reservedOp "="
140                 pString
141
142 pMatchable =
143         choice $ map (\(a,b) -> const b `fmap` reserved a) $
144                 [ ("LIGHT", MatchLight)
145                 , ("LENGTH", MatchLength)
146                 , ("SUBLENGTH", MatchSubLength)
147                 , ("SUBLIGHT", MatchSubLight)
148                 , ("ANGLE", MatchAngle)
149                 , ("DIRECTION", MatchDirection)
150                 ]
151
152 pCmp = 
153         choice $ map (\(a,b) -> const b `fmap` reservedOp a) $
154                 [ ("<=", LE)
155                 , ("<",  Less)
156                 , ("=",  Equals)
157                 , (">",  Greater)
158                 , (">=", GE)
159                 ]
160
161 pString = identifier <|> stringLiteral
162
163 pFloat = do value <- try (do 
164                         i <- fromIntegral `fmap` integer
165                         notFollowedBy (char '.')
166                         return i
167                      )  <|> float
168             (deg >> return (value / 180 * pi)) <|> return value
169
170 deg = reservedOp "\194\176"