@@ -35,51 +35,6 @@ import qualified Data.ByteString.UTF8 as UTF8
3535
3636import Debug.Trace
3737
38−data SyntaxRules = SyntaxRules
39− { rules_rules :: [Syntax]
40− , rules_parserPattern :: (SyntaxInfo -> IdrisParser PTerm)
41− , rules_parserTerm :: (SyntaxInfo -> IdrisParser PTerm)
42− , rules_parserSimplePattern :: (SyntaxInfo -> IdrisParser PTerm)
43− , rules_parserSimpleTerm :: (SyntaxInfo -> IdrisParser PTerm)
44− }
45−
46−emptySyntaxRules :: SyntaxRules
47−emptySyntaxRules = SyntaxRules
48− { rules_rules = []
49− , rules_parserPattern = const empty
50− , rules_parserTerm = const empty
51− , rules_parserSimplePattern = const empty
52− , rules_parserSimpleTerm = const empty
53− }
54−
55−updateSyntaxRules :: [Syntax] -> SyntaxRules -> SyntaxRules
56−updateSyntaxRules rules sr = sr
57− { rules_rules = newRules
58− , rules_parserPattern = \syn -> extensions syn $ filter isPattern newRules
59− , rules_parserTerm = \syn -> extensions syn $ filter isTerm newRules
60− , rules_parserSimplePattern = \syn ->
61− extensions syn $ filter isPattern $ filter isSimple $ newRules
62− , rules_parserSimpleTerm = \syn ->
63− extensions syn $ filter isTerm $ filter isSimple $ newRules
64− }
65− where
66− newRules = rules ++ rules_rules sr
67− isSimple (Rule (Expr x:xs) _ _) = False
68− isSimple (Rule (SimpleExpr x:xs) _ _) = False
69− isSimple (Rule [Keyword _] _ _) = True
70− isSimple (Rule [Symbol _] _ _) = True
71− isSimple (Rule (_:xs) _ _) = case last xs of
72− Keyword _ -> True
73− Symbol _ -> True
74− _ -> False
75− isSimple _ = False
76− isPattern (Rule _ _ AnySyntax) = True
77− isPattern (Rule _ _ PatternSyntax) = True
78− isPattern _ = False
79− isTerm (Rule _ _ AnySyntax) = True
80− isTerm (Rule _ _ TermSyntax) = True
81− isTerm _ = False
82−
8338-- | Allow implicit type declarations
8439allowImp :: SyntaxInfo -> SyntaxInfo
8540allowImp syn = syn { implicitAllowed = True }
@@ -137,69 +92,51 @@ expr' syn = try (externalExpr syn)
13792{- | Parses a user-defined expression -}
13893externalExpr :: SyntaxInfo -> IdrisParser PTerm
13994externalExpr syn = do i <- get
140− if inPattern syn
141− then rules_parserPattern (syntax_rules i) syn
142− else rules_parserTerm (syntax_rules i) syn
95+ extensions syn (syntaxRulesList $ syntax_rules i)
14396 <?> "user-defined expression"
14497
14598{- | Parses a simple user-defined expression -}
14699simpleExternalExpr :: SyntaxInfo -> IdrisParser PTerm
147100simpleExternalExpr syn = do i <- get
148− if inPattern syn
149− then rules_parserSimplePattern (syntax_rules i) syn
150− else rules_parserSimpleTerm (syntax_rules i) syn
151−
152−data SynMatch = SynTm PTerm | SynBind Name
101+ extensions syn (filter isSimple (syntaxRulesList $ syntax_rules i))
102+ where
103+ isSimple (Rule (Expr x:xs) _ _) = False
104+ isSimple (Rule (SimpleExpr x:xs) _ _) = False
105+ isSimple (Rule [Keyword _] _ _) = True
106+ isSimple (Rule [Symbol _] _ _) = True
107+ isSimple (Rule (_:xs) _ _) = case last xs of
108+ Keyword _ -> True
109+ Symbol _ -> True
110+ _ -> False
111+ isSimple _ = False
153112
154113{- | Tries to parse a user-defined expression given a list of syntactic extensions -}
155114extensions :: SyntaxInfo -> [Syntax] -> IdrisParser PTerm
156−extensions syn rules = extension [] (sortBy (ruleSort `on` syntaxSymbols) rules)
115+extensions syn rules = extension syn [] (filter isValid rules)
157116 <?> "user-defined expression"
158117 where
159− extension ns rules =
160− choice $ flip map (groupBy (ruleGroup `on` syntaxSymbols) rules) $ \rs ->
161− case head rs of -- can never be []
162− Rule (symb:_) _ _ -> try $ do
163− n <- extensionSymbol symb
164− extension (n : ns) [Rule ss t ctx | (Rule (_:ss) t ctx) <- rs]
165− -- If we have more than one Rule in this bucket, our grammar is
166− -- nondeterministic.
167− Rule [] ptm _ -> return (flatten (update (mapMaybe id ns) ptm))
118+ isValid :: Syntax -> Bool
119+ isValid (Rule _ _ AnySyntax) = True
120+ isValid (Rule _ _ PatternSyntax) = inPattern syn
121+ isValid (Rule _ _ TermSyntax) = not (inPattern syn)
122+
123+data SynMatch = SynTm PTerm | SynBind Name
168124
125+extension :: SyntaxInfo -> [Maybe (Name, SynMatch)] -> [Syntax] -> IdrisParser PTerm
126+extension syn ns rules =
127+ choice $ flip map (groupBy (ruleGroup `on` syntaxSymbols) rules) $ \rs ->
128+ case head rs of -- can never be []
129+ Rule (symb:_) _ _ -> try $ do
130+ n <- extensionSymbol symb
131+ extension syn (n : ns) [Rule ss t ctx | (Rule (_:ss) t ctx) <- rs]
132+ -- If we have more than one Rule in this bucket, our grammar is
133+ -- nondeterministic.
134+ Rule [] ptm _ -> return (flatten (update (mapMaybe id ns) ptm))
135+ where
169136 ruleGroup [] [] = True
170137 ruleGroup (s1:_) (s2:_) = s1 == s2
171138 ruleGroup _ _ = False
172139
173− ruleSort [] [] = EQ
174− ruleSort [] _ = LT
175− ruleSort _ [] = GT
176− ruleSort (s1:ss1) (s2:ss2) =
177− case symCompare s1 s2 of
178− EQ -> ruleSort ss1 ss2
179− r -> r
180−
181− -- Better than creating Ord instance for SSymbol since
182− -- in general this ordering does not really make sense.
183− symCompare (Keyword n1) (Keyword n2) = compare n1 n2
184− symCompare (Keyword _) _ = LT
185− symCompare (Symbol _) (Keyword _) = GT
186− symCompare (Symbol s1) (Symbol s2) = compare s1 s2
187− symCompare (Symbol _) _ = LT
188− symCompare (Binding _) (Keyword _) = GT
189− symCompare (Binding _) (Symbol _) = GT
190− symCompare (Binding b1) (Binding b2) = compare b1 b2
191− symCompare (Binding _) _ = LT
192− symCompare (Expr _) (Keyword _) = GT
193− symCompare (Expr _) (Symbol _) = GT
194− symCompare (Expr _) (Binding _) = GT
195− symCompare (Expr e1) (Expr e2) = compare e1 e2
196− symCompare (Expr _) _ = LT
197− symCompare (SimpleExpr _) (Keyword _) = GT
198− symCompare (SimpleExpr _) (Symbol _) = GT
199− symCompare (SimpleExpr _) (Binding _) = GT
200− symCompare (SimpleExpr _) (Expr _) = GT
201− symCompare (SimpleExpr e1) (SimpleExpr e2) = compare e1 e2
202−
203140 extensionSymbol :: SSymbol -> IdrisParser (Maybe (Name, SynMatch))
204141 extensionSymbol (Keyword n) = do reserved (show n); return Nothing
205142 extensionSymbol (Expr n) = do tm <- expr syn