← Back to branch summary

~ubuntu-branches/ubuntu/wily/agda/wily-proposed

« back to all changes in this revision

Viewing changes to src/prototyping/mixfix/ExpressionParser.hs

  • Committer: Package Import Robot
  • Author(s): Iain Lane
  • Date: 2014-08-05 06:38:12 UTC
  • mfrom: (1.1.6)
  • Revision ID: package-import@ubuntu.com-20140805063812-io8e77niomivhd49
Tags: 2.4.0.2-1
* [6e140ac] Imported Upstream version 2.4.0.2
* [2049fc8] Update Build-Depends to match control
* [93dc4d4] Install the new primitives
* [e48f40f] Fix typo dev→doc

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/prototyping/mixfix/ExpressionParser.hs
1
 
------------------------------------------------------------------------
2
 
------------------------------------------------------------------------
3
 
 
4
 
{-# LANGUAGE FlexibleContexts, GADTs #-}
5
 
 
6
 
module ExpressionParser
7
 
  ( NT
8
 
  , parse
9
 
  ) where
10
 
 
11
 
import qualified Parser
12
 
import Parser hiding (parse)
13
 
import PrecedenceGraph
14
 
import Utilities
15
 
import IndexedOrd
16
 
import Name
17
 
import Token
18
 
import Expression
19
 
import qualified MemoisedCPS
20
 
 
21
 
import Control.Applicative as A
22
 
import Data.Foldable (asum)
23
 
import qualified Data.List as List
24
 
import qualified Data.Set  as Set
25
 
import Data.Set (Set)
26
 
 
27
 
 
28
 
(!*) :: Annotation -> Fixity -> Set Name
29
 
m !* k = Set.unions [m ! (k, ass) | ass <- [Non, L, R]]
30
 
 
31
 
 
32
 
type Op = (Name, [Maybe Expr])
33
 
 
34
 
 
35
 
appLeft :: Maybe Expr -> Op -> Op
36
 
appLeft e (u, es) = (u, e : es)
37
 
 
38
 
appRight :: Op -> Maybe Expr -> Op
39
 
appRight (u, es) e = (u, es ++ [e])
40
 
 
41
 
appBoth :: Maybe Expr -> Op -> Maybe Expr -> Op
42
 
appBoth e1 o e2 = appLeft e1 (appRight o e2)
43
 
 
44
 
 
45
 
toE :: Op -> Expr
46
 
toE (u, es) = Op u es
47
 
 
48
 
 
49
 
data NT r where
50
 
  ExprN      :: Set Node -> NT Expr
51
 
  OpN        :: Set Name -> NT Op
52
 
  NodeN      :: Node     -> NT Expr
53
 
  PostLeftsN :: Node     -> NT Expr
54
 
  AtomN      ::             NT Expr
55
 
 
56
 
 
57
 
expression :: PrecedenceGraph -> NT Expr
58
 
expression g = ExprN (nodes g)
59
 
 
60
 
 
61
 
placeholder :: NTParser p NT Token => Pos -> p (Maybe Expr)
62
 
placeholder p = Nothing <$ sym (Placeholder p)
63
 
 
64
 
 
65
 
namePart :: NTParser p NT Token
66
 
         => [String]
67
 
         -- ^ Module name.
68
 
         -> String
69
 
         -- ^ Name part.
70
 
         -> p ()
71
 
namePart ms n = symbol >>= \s -> case s of
72
 
  QualifiedName ms' n' -> if ms' `List.isSuffixOf` ms && n' == n
73
 
                          then return () else A.empty
74
 
  _ -> A.empty
75
 
 
76
 
 
77
 
grammar :: NTParser p NT Token =>
78
 
           PrecedenceGraph ->
79
 
           -- ^ The precedence graph.
80
 
           (Name -> Set Name) ->
81
 
           -- ^ A function giving all qualified names matching the
82
 
           -- given qualified name (which might be given with an
83
 
           -- incomplete module name prefix).
84
 
           Set Name ->
85
 
           -- ^ Closed mixfix operators.
86
 
           NT r -> p r
87
 
 
88
 
 
89
 
 
90
 
grammar g lookupName closed AtomN =
91
 
      Fun <$> (asum =<< map return . filter (not . isOperator) .
92
 
                        Set.toList . lookupName <$> parseName)
93
 
  <|> WildcardE <$ sym Wildcard
94
 
  <|> sym LParen *> nonTerm (expression g) <* sym RParen
95
 
  <|> toE <$> (      nonTerm (OpN closed)
96
 
    <|> appRight <$> nonTerm (OpN prefix) <*> placeholder End
97
 
    <|> appLeft  <$> placeholder Beg <*> nonTerm (OpN postfix)
98
 
    <|> appBoth  <$> placeholder Beg <*> nonTerm (OpN infx) <*>
99
 
                     placeholder End)
100
 
  where
101
 
  allOps  = allOperators g
102
 
  prefix  = allOps !* Prefix
103
 
  postfix = allOps !* Postfix
104
 
  infx    = allOps !* Infix
105
 
 
106
 
 
107
 
grammar _ _ _ (ExprN ns)
108
 
   =  app <$> nonTerm AtomN <*> many (nonTerm AtomN)
109
 
  <|> asum (map (nonTerm . NodeN) $ Set.toList ns)
110
 
 
111
 
 
112
 
grammar g _ _ (OpN ops) = asum $ map op (Set.toList ops)
113
 
  where
114
 
  op n = (,) n <$>
115
 
    (Just <$> nonTerm (expression g) <|> placeholder Mid)
116
 
      `between`
117
 
    map (namePart (moduleName n)) (nameParts n)
118
 
 
119
 
 
120
 
grammar g _ _ (NodeN n) =
121
 
  nonAssoc <|> preRights <|> nonTerm (PostLeftsN n)
122
 
  where
123
 
  -- Applications of non-associative operators.
124
 
  nonAssoc = appBoth' <$>
125
 
    higher g n <*> internal g n Infix Non <*> higher g n
126
 
 
127
 
  -- Sequences of prefix/infix right-associative operators.
128
 
  preRights = preRight <*> (preRights <|> higher g n)
129
 
    where
130
 
    preRight =  appRight' <$>                internal g n Prefix Non
131
 
            <|> appBoth'  <$> higher g n <*> internal g n Infix  R
132
 
 
133
 
  appRight'    o e2 = toE $ appRight           o (Just e2)
134
 
  appBoth'  e1 o e2 = toE $ appBoth  (Just e1) o (Just e2)
135
 
 
136
 
 
137
 
grammar g _ _ (PostLeftsN n) = flip ($) <$>
138
 
  (nonTerm (PostLeftsN n) <|> higher g n) <*> postLeft
139
 
  where
140
 
  postLeft =  appLeft' <$> internal g n Postfix Non
141
 
          <|> appBoth' <$> internal g n Infix   L   <*> higher g n
142
 
 
143
 
  appLeft' o    e1 = toE $ appLeft (Just e1) o
144
 
  appBoth' o e2 e1 = toE $ appBoth (Just e1) o (Just e2)
145
 
 
146
 
 
147
 
internal :: NTParser p NT Token =>
148
 
            PrecedenceGraph -> Node -> Fixity -> Assoc -> p Op
149
 
internal g n f ass =
150
 
      nonTerm (OpN (ann ! (f, ass)))
151
 
  <|> case f of
152
 
        Prefix  -> appLeft  <$> placeholder Beg <*> infx
153
 
        Postfix -> appRight <$> infx <*> placeholder End
154
 
        Infix   -> A.empty
155
 
  where
156
 
  ann  = annotation g n
157
 
  infx = nonTerm (OpN (ann !* Infix))
158
 
 
159
 
 
160
 
higher :: NTParser p NT Token =>
161
 
          PrecedenceGraph -> Node -> p Expr
162
 
higher g n = nonTerm (ExprN (successors g n))
163
 
 
164
 
 
165
 
parse :: PrecedenceGraph ->
166
 
         -- ^ The precedence graph.
167
 
         (Name -> Set Name) ->
168
 
         -- ^ A function giving all qualified names matching the
169
 
         -- given qualified name (which might be given with an
170
 
         -- incomplete module name prefix).
171
 
         Set Name ->
172
 
         -- ^ Closed mixfix operators.
173
 
         [Token] ->
174
 
         -- ^ Input tokens.
175
 
         [Expr]
176
 
parse g lookupName closed =
177
 
  MemoisedCPS.parse (grammar g lookupName closed)
178
 
                    (nonTerm $ expression g)
179
 
 
180
 
------------------------------------------------------------------------
181
 
 
182
 
instance IndexedEq NT where
183
 
  iEq (ExprN ns1)     (ExprN ns2)     = boolToEq $ ns1 == ns2
184
 
  iEq (OpN ns1)       (OpN ns2)       = boolToEq $ ns1 == ns2
185
 
  iEq (NodeN n1)      (NodeN n2)      = boolToEq $ n1  == n2
186
 
  iEq (PostLeftsN n1) (PostLeftsN n2) = boolToEq $ n1  == n2
187
 
  iEq AtomN           AtomN           = Just Refl
188
 
  iEq _               _               = Nothing
189
 
 
190
 
instance IndexedOrd NT where
191
 
  iCompare (ExprN ns1)     (ExprN ns2)     = compare ns1 ns2
192
 
  iCompare (OpN ns1)       (OpN ns2)       = compare ns1 ns2
193
 
  iCompare (NodeN n1)      (NodeN n2)      = compare n1 n2
194
 
  iCompare (PostLeftsN n1) (PostLeftsN n2) = compare n1 n2
195
 
  iCompare AtomN           AtomN           = EQ
196
 
  iCompare (ExprN _)       _               = LT
197
 
  iCompare (OpN _)         (ExprN _)       = GT
198
 
  iCompare (OpN _)         _               = LT
199
 
  iCompare (NodeN _)       (ExprN _)       = GT
200
 
  iCompare (NodeN _)       (OpN _)         = GT
201
 
  iCompare (NodeN _)       _               = LT
202
 
  iCompare (PostLeftsN _)  AtomN           = LT
203
 
  iCompare (PostLeftsN _)  _               = GT
204
 
  iCompare AtomN           _               = GT