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 -- Note that the type of "loop" is NOT (forall c s. <[s -> Bool]>@c)
114 -- because "k" is free here; this restrictionis analogous to the free
115 -- environment variable in Nanevski's example.
116 loop emptyOk = if emptyOk
117 then <[ \s -> ~~k s || ~~(staged_accept e True (loop False)) s ]>
118 else <[ \s -> ~~(staged_accept e False (loop False)) s ]>
120 staged_accept (Const c) emptyOk k =
121 <[ \s -> if gs_empty s
123 else (gs_head s) == ~~(guestCharLiteral c) && ~~k (gs_tail s) ]>
126 -- Take particular note of the "Plus" case above: note that (following
127 -- Nanevski+Pfenning) the code for "k" is not duplicated -- it is
128 -- escapified into the constructed term only once, and a tiny scrap of
129 -- code containing nothing more than the variable name k' is passed
130 -- to the recursive call. This is in contrast with the naive implementation
133 -- staged_accept (Plus e1 e2) emptyOk k =
134 -- <[ \s -> (~~(staged_accept e1 emptyOk k) s) ||
135 -- (~~(staged_accept e2 emptyOk k) s)
140 -- The following commented-out type is "too polymorphic" -- try
141 -- uncommenting it to see what happens. It's a great example of the
142 -- kind of thing that environment classifiers guard against: the
143 -- continuation code and the result code get their classifiers
152 GuestCharLiteral c =>
153 GuestLanguageBool c =>
158 GuestCharLiteral c =>
159 GuestLanguageBool c =>