6228a901643e6a9fdaa1841fca8bb9b67c6e49de
[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", "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 <- optionMaybe $ do
111                 reserved "SET"
112                 reserved "TAG"
113                 reservedOp "="
114                 pString
115         return (AddBranches mTag (fraction/100) branches)
116
117 pGrow :: Parser GrammarAction
118 pGrow = do
119         reserved "GROW"
120         desc <- by <|> to
121         mTag <- optionMaybe $ do
122                 reserved "SET"
123                 reserved "TAG"
124                 reservedOp "="
125                 pString
126         return (SetLength mTag desc)
127   where by = do
128                 reserved "BY"
129                 value <- pFloat
130                 (reservedOp "%" >> return (AdditionalRelative value)) <|>
131                                    return (Additional value)
132         to = do
133                 reserved "TO"
134                 value <- pFloat
135                 return (Absolute value)
136
137 pBlossom :: Parser GrammarAction
138 pBlossom = do
139         reserved "BLOSSOM"
140         return Blossom
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"