1 {-# OPTIONS_GHC -XModalTypes -XMultiParamTypeClasses -ddump-types #-}
4 import GHC.HetMet.CodeTypes hiding ((-))
6 --------------------------------------------------------------------------------
8 -- A one-level Regular Expression matcher, adapted from
9 -- Nanevski+Pfenning's _Staged computation with names and necessity_,
25 -- A continuation-passing-style matcher. If the "b" argument is false
26 -- the expression must match at least one character before passing
27 -- control to the continuation (this avoids the equality test in the
28 -- Nanevski+Pfenning code)
32 Bool -> -- may only match the empty string if this is True
37 accept Empty False k s =
40 accept Empty True k s =
43 accept (Plus e1 e2) emptyOk k s =
44 (accept e1 emptyOk k s) || (accept e2 emptyOk k s)
46 accept (Times e1 e2) True k s =
47 (accept e1 True (accept e2 True k)) s
49 accept (Times e1 e2) False k s =
50 (accept e1 False (accept e2 True k)) s ||
51 (accept e1 True (accept e2 False k)) s
53 accept (Star e) emptyOk k s =
55 (accept e emptyOk (\s' -> accept (Star e) False k s') s)
57 accept (Const c) emptyOk k s =
60 else (s_head s) == c && k (s_tail s)
64 --------------------------------------------------------------------------------
66 -- A two-level Regular Expression matcher, adapted from
67 -- Nanevski+Pfenning's _Staged computation with names and necessity_,
71 class GuestStream g a where
72 <[ gs_empty ]> :: <[ a -> Bool ]>@g
73 <[ gs_head ]> :: <[ a -> Char ]>@g
74 <[ gs_tail ]> :: <[ a -> a ]>@g
76 class GuestEqChar g where
77 <[ (==) ]> :: <[ Char -> Char -> Bool ]>@g
85 GuestLanguageBool c =>
90 staged_accept Empty False k =
93 staged_accept Empty True k =
94 <[ \s -> gs_empty s ]>
96 staged_accept (Plus e1 e2) emptyOk k =
98 in (~~(staged_accept e1 emptyOk <[k']>) s) ||
99 (~~(staged_accept e2 emptyOk <[k']>) s)
102 staged_accept (Times e1 e2) True k =
103 <[ \s -> ~~(staged_accept e1 True (staged_accept e2 True k)) s ]>
105 staged_accept (Times e1 e2) emptyOk k =
106 <[ \s -> ~~(staged_accept e1 True (staged_accept e2 False k)) s ||
107 ~~(staged_accept e1 False (staged_accept e2 True k)) s
110 staged_accept (Star e) emptyOk' k =
113 -- loop :: Bool -> <[s -> Bool]>@g
114 loop emptyOk = if emptyOk
115 then <[ \s -> ~~k s || ~~(staged_accept e True (loop False)) s ]>
116 else <[ \s -> ~~(staged_accept e False (loop False)) s ]>
117 -- note that loop is not (forall c s. <[s -> Bool]>@c)
118 -- because "k" is free in loop; it is analogous to the free
119 -- environment variable in Nanevski's example
121 staged_accept (Const c) emptyOk k =
122 <[ \s -> if gs_empty s
124 else (gs_head s) == ~~(guestCharLiteral c) && ~~k (gs_tail s) ]>
127 -- Take particular note of the "Plus" case above: note that (following
128 -- Nanevski+Pfenning) the code for "k" is not duplicated -- it is
129 -- escapified into the constructed term only once, and a tiny scrap of
130 -- code containing nothing more than the variable name k' is passed
131 -- to the recursive call. This is in contrast with the naive implementation
134 -- staged_accept (Plus e1 e2) emptyOk k =
135 -- <[ \s -> (~~(staged_accept e1 emptyOk k) s) ||
136 -- (~~(staged_accept e2 emptyOk k) s)
141 -- The following commented-out type is "too polymorphic" -- try
142 -- uncommenting it to see what happens. It's a great example of the
143 -- kind of thing that environment classifiers guard against: the
144 -- continuation code and the result code get their classifiers
153 GuestCharLiteral c =>
154 GuestLanguageBool c =>
159 GuestCharLiteral c =>
160 GuestLanguageBool c =>