never executed always true always false
1 module Conjure.Language.ParserCPrime
2 ( parseModel
3 )
4 where
5
6 import Conjure.Prelude
7 import Conjure.Language.Definition
8 import Conjure.Language.Domain
9 import Conjure.Language.Type ( IntTag(..), Type(..) )
10 import Conjure.Language.Pretty ( pretty, vcat, (<+>) )
11
12 import qualified Data.Text as T
13 import Data.Char ( isAlpha, isAlphaNum, isDigit )
14
15
16 -- | Fast parser for Essence Prime solution lines.
17 -- Supports only: bools, ints, and matrices (nested).
18 parseModel :: Text -> Either Doc Model
19 parseModel input = do
20 lettings <- collectLettings (T.strip input) []
21 let stmts = [ Declaration (Letting nm (Constant c)) | (nm, c) <- reverse lettings ]
22 return (languageEprime def) { mStatements = stmts }
23
24
25 collectLettings :: Text -> [(Name, Constant)] -> Either Doc [(Name, Constant)]
26 collectLettings txt acc =
27 case findLetting txt of
28 Nothing -> Right acc
29 Just rest -> do
30 (nm, c, rest') <- parseLetting rest
31 collectLettings rest' ((nm, c) : acc)
32
33
34 findLetting :: Text -> Maybe Text
35 findLetting txt =
36 case T.breakOn "letting" txt of
37 (_, rest) | T.null rest -> Nothing
38 (prefix, rest) ->
39 let beforeOk = T.null prefix || isSpace (T.last prefix)
40 after = T.drop (T.length ("letting" :: Text)) rest
41 afterOk = case T.uncons after of
42 Just (c, _) -> isSpace c
43 Nothing -> False
44 in if beforeOk && afterOk
45 then Just (T.dropWhile isSpace after)
46 else findLetting (T.drop 1 rest)
47
48
49 parseLetting :: Text -> Either Doc (Name, Constant, Text)
50 parseLetting txt = do
51 (nmTxt, rest1) <- parseIdentifier txt
52 rest2 <- parseKeyword "be" rest1
53 (c, rest3) <- parseConstant rest2
54 return (Name nmTxt, c, rest3)
55
56
57 parseKeyword :: Text -> Text -> Either Doc Text
58 parseKeyword kw txt = do
59 (tok, rest) <- parseIdentifier txt
60 if tok == kw then Right rest else parseError "Expected keyword" txt
61
62
63 parseIdentifier :: Text -> Either Doc (Text, Text)
64 parseIdentifier txt =
65 let t = skipSpaces txt
66 in case T.uncons t of
67 Just (c, rest) | isIdentStart c ->
68 let (tok, rest') = T.span isIdentChar rest
69 in Right (T.cons c tok, rest')
70 _ -> parseError "Expected identifier" txt
71
72
73 parseConstant :: Text -> Either Doc (Constant, Text)
74 parseConstant txt =
75 let t = skipSpaces txt
76 in case T.uncons t of
77 Nothing -> parseError "Unexpected end of input while parsing constant" txt
78 Just ('[', _) -> parseMatrix t
79 Just ('(', _) -> parseAnnotatedEmptyMatrix t
80 Just (c, _) | c == '-' || isDigit c -> parseInt t
81 _ -> do
82 (tok, rest) <- parseIdentifier t
83 case tok of
84 "true" -> Right (ConstantBool True, rest)
85 "false" -> Right (ConstantBool False, rest)
86 _ -> parseError "Expected boolean constant" t
87
88
89 parseInt :: Text -> Either Doc (Constant, Text)
90 parseInt txt =
91 let t = skipSpaces txt
92 (sign, t1) =
93 case T.uncons t of
94 Just ('-', rest1) -> (-1, rest1)
95 _ -> (1, t)
96 (digits, rest) = T.span isDigit t1
97 in if T.null digits
98 then parseError "Expected integer constant" txt
99 else
100 let n = sign * parseInteger digits
101 in Right (ConstantInt TagInt n, rest)
102
103
104 parseMatrix :: Text -> Either Doc (Constant, Text)
105 parseMatrix txt = do
106 t1 <- expectChar '[' txt
107 let t2 = skipSpaces t1
108 case T.uncons t2 of
109 Just (']', rest) ->
110 let dom = DomainInt TagInt []
111 in Right (ConstantAbstract (AbsLitMatrix dom []), rest)
112 _ -> do
113 (firstVal, rest1) <- parseConstant t2
114 (vals, mDom, rest2) <- parseMatrixRest [firstVal] rest1
115 let dom =
116 case mDom of
117 Just d -> d
118 Nothing ->
119 if null vals
120 then DomainInt TagInt []
121 else DomainInt TagInt [RangeBounded (ConstantInt TagInt 1) (ConstantInt TagInt (genericLength vals))]
122 return (ConstantAbstract (AbsLitMatrix dom vals), rest2)
123
124
125 parseMatrixRest :: [Constant] -> Text -> Either Doc ([Constant], Maybe (Domain () Constant), Text)
126 parseMatrixRest acc txt =
127 let t = skipSpaces txt
128 in case T.uncons t of
129 Just (',', rest) -> do
130 (val, rest') <- parseConstant rest
131 parseMatrixRest (val : acc) rest'
132 Just (';', rest) -> do
133 (dom, rest') <- parseDomain rest
134 rest'' <- expectChar ']' rest'
135 Right (reverse acc, Just dom, rest'')
136 Just (']', rest) -> Right (reverse acc, Nothing, rest)
137 _ -> parseError "Expected ',', ';' or ']'" txt
138
139
140 parseDomain :: Text -> Either Doc (Domain () Constant, Text)
141 parseDomain txt = do
142 (tok, rest) <- parseIdentifier txt
143 case tok of
144 "bool" -> Right (DomainBool, rest)
145 "int" -> parseIntDomain rest
146 _ -> parseError "Expected domain (bool or int(...))" txt
147
148
149 parseIntDomain :: Text -> Either Doc (Domain () Constant, Text)
150 parseIntDomain txt = do
151 t1 <- expectChar '(' txt
152 let t1' = skipSpaces t1
153 case T.uncons t1' of
154 Just (')', rest) -> return (DomainInt TagInt [], rest)
155 _ -> do
156 (ranges, rest) <- parseRanges [] t1
157 rest' <- expectChar ')' rest
158 return (DomainInt TagInt (reverse ranges), rest')
159
160
161 parseRanges :: [Range Constant] -> Text -> Either Doc ([Range Constant], Text)
162 parseRanges acc txt = do
163 (r, rest) <- parseRange txt
164 let t = skipSpaces rest
165 case T.uncons t of
166 Just (',', rest') -> parseRanges (r : acc) rest'
167 _ -> Right (r : acc, rest)
168
169
170 parseRange :: Text -> Either Doc (Range Constant, Text)
171 parseRange txt = do
172 (c1, rest1) <- parseInt txt
173 let t = skipSpaces rest1
174 case T.stripPrefix ".." t of
175 Just rest2 -> do
176 (c2, rest3) <- parseInt rest2
177 return (RangeBounded c1 c2, rest3)
178 Nothing -> return (RangeSingle c1, rest1)
179
180
181 expectChar :: Char -> Text -> Either Doc Text
182 expectChar c txt =
183 let t = skipSpaces txt
184 in case T.uncons t of
185 Just (d, rest) | d == c -> Right rest
186 _ -> parseError (T.concat ["Expected '", T.singleton c, "'"]) txt
187
188
189 skipSpaces :: Text -> Text
190 skipSpaces = T.dropWhile isSpace
191
192
193 isIdentStart :: Char -> Bool
194 isIdentStart c = isAlpha c || c == '_'
195
196
197 isIdentChar :: Char -> Bool
198 isIdentChar c = isAlphaNum c || c == '_' || c == '\''
199
200
201 parseError :: Text -> Text -> Either Doc a
202 parseError msg txt =
203 let snippet = T.take 80 (skipSpaces txt)
204 in Left $ vcat
205 [ "Fast solution parser error:" <+> pretty msg
206 , "Near:" <+> pretty snippet
207 ]
208
209
210 parseAnnotatedEmptyMatrix :: Text -> Either Doc (Constant, Text)
211 parseAnnotatedEmptyMatrix txt = do
212 t1 <- expectChar '(' txt
213 t2 <- expectChar '[' t1
214 t3 <- expectChar ']' t2
215 t4 <- expectChar ':' t3
216 t5 <- expectChar '`' t4
217 ((indexDomains, innerDomain), t6) <- parseMatrixTypeInBackticks t5
218 t7 <- expectChar '`' t6
219 t8 <- expectChar ')' t7
220 let indexDomain =
221 case indexDomains of
222 d : _ -> d
223 [] -> DomainInt TagInt []
224 let ty = typeFromDomains indexDomains innerDomain
225 let c = TypedConstant (ConstantAbstract (AbsLitMatrix indexDomain [])) ty
226 return (c, t8)
227
228
229 parseMatrixTypeInBackticks :: Text -> Either Doc (([Domain () Constant], Domain () Constant), Text)
230 parseMatrixTypeInBackticks txt = do
231 t1 <- parseWord "matrix" txt
232 t2 <- parseWord "indexed" t1
233 t3 <- parseWord "by" t2
234 t4 <- expectChar '[' t3
235 (indexDomains, t5) <- parseDomainList t4
236 t6 <- expectChar ']' t5
237 t7 <- parseWord "of" t6
238 (innerDomain, t8) <- parseDomain t7
239 return ((indexDomains, innerDomain), t8)
240
241
242 parseDomainList :: Text -> Either Doc ([Domain () Constant], Text)
243 parseDomainList txt = do
244 (d, rest) <- parseDomain txt
245 let t = skipSpaces rest
246 case T.uncons t of
247 Just (',', rest') -> do
248 (ds, rest'') <- parseDomainList rest'
249 return (d : ds, rest'')
250 _ -> return ([d], rest)
251
252
253 parseWord :: Text -> Text -> Either Doc Text
254 parseWord w txt = do
255 (tok, rest) <- parseIdentifier txt
256 if tok == w
257 then Right rest
258 else parseError (T.concat ["Expected '", w, "'"]) txt
259
260
261 typeFromDomains :: [Domain () Constant] -> Domain () Constant -> Type
262 typeFromDomains indices inner =
263 foldr TypeMatrix (typeFromDomain inner) (map typeFromDomain indices)
264
265
266 typeFromDomain :: Domain () Constant -> Type
267 typeFromDomain DomainBool = TypeBool
268 typeFromDomain (DomainInt t _) = TypeInt t
269 typeFromDomain _ = TypeAny
270
271
272 parseInteger :: Text -> Integer
273 parseInteger =
274 T.foldl' (\acc d -> acc * 10 + toInteger (fromEnum d - fromEnum '0')) 0