Difference between revisions of "Embedding context free grammars"
Jump to navigation
Jump to search
m |
|||
(7 intermediate revisions by 4 users not shown) | |||
Line 2: | Line 2: | ||
<haskell> |
<haskell> |
||
+ | |||
− | data Grammar b where |
||
+ | import Maybe |
||
− | Ref :: Grammar c |
||
+ | data Grammar a b where |
||
− | Tok :: Char -> Grammar c |
||
− | + | NullParser :: Grammar a b |
|
− | + | Check :: (a -> Bool) -> Grammar a a |
|
− | (:|) :: Grammar b -> Grammar b -> Grammar b |
+ | (:|) :: (Grammar a b) -> (Grammar a b) -> Grammar a b |
− | + | Push :: a -> (Grammar a b) -> Grammar a b |
|
− | + | (:&) :: (Grammar a b) -> (Grammar a c) -> Grammar a (b,c) |
|
− | + | FMap :: Grammar a c -> (c -> b) -> Grammar a b |
|
+ | |||
+ | |||
infixl 6 :| |
infixl 6 :| |
||
− | infixl 7 :& |
||
− | parse:: [Char] -> Grammar b -> Grammar b -> Bool |
||
− | parse x Ref t = parse x t t |
||
− | parse [c] (Tok c') _ = c == c' |
||
− | parse [c] (Check y) _ = y c |
||
− | parse _ (Tok _) _ = False |
||
− | parse _ (Check _) _ = False |
||
− | parse x (Fix g) _ = parse x g (Fix g) |
||
− | parse x (g :| g') t = parse x g t || parse x g' t --cool little trick! |
||
− | parse (x:xs) (g :& g') t = parse xs ((Push x g) :& g') t || (parse [] g t && parse (x:xs) g' t) |
||
− | parse x (Push c g) t = parse (c:x) g t |
||
− | parse _ NullParser _ = False |
||
− | parse [] _ _ = False |
||
− | + | tok x = Check (x==) |
|
− | </haskell> |
||
+ | parse :: [a] -> Grammar a b -> Maybe b |
||
− | and here's a lambda calculus parser written in this embedded language |
||
+ | parse [c] (Check y) = if y c then Just c else Nothing |
||
− | <haskell> |
||
− | + | parse x (g :| g') = |
|
− | + | let |
|
+ | r1 = parse x g |
||
− | term = var :| abstraction :| parenedTerm |
||
+ | r2 = parse x g' |
||
− | parenedTerm = Tok '(' :& term :& Tok ')' |
||
+ | in |
||
− | abstraction = Tok '\\' :& var :& Tok '.' :& term |
||
+ | if isJust r1 then r1 else r2 |
||
− | top = term :& Tok ';' |
||
− | <haskell> |
||
+ | parse (x:xs) (g :& g') = |
||
− | let's see the results |
||
+ | let |
||
− | <haskell> |
||
− | + | r1 = parse xs ((Push x g) :& g') |
|
+ | r2 = parse [] g |
||
− | > True |
||
+ | r3 = parse (x:xs) g' |
||
+ | in |
||
+ | if isJust r1 |
||
+ | then r1 |
||
+ | else |
||
+ | if (isJust r2) && (isJust r3) |
||
+ | then Just (fromJust r2, fromJust r3) |
||
+ | else Nothing |
||
+ | parse x (Push c g) = parse (c:x) g |
||
+ | parse x (FMap y f) = parse x y >>= f |
||
+ | parse _ _ = Nothing |
||
+ | |||
+ | infixl 7 ~& |
||
+ | infixl 7 ~&& |
||
+ | infixl 7 ~&&& |
||
+ | infixl 7 ~&&&& |
||
+ | |||
+ | (~&) = (:&) |
||
+ | |||
+ | a ~&& b = FMap |
||
+ | (a :& b) |
||
+ | (\((a,b),c) -> (a,b,c)) |
||
+ | |||
+ | a ~&&& b = FMap |
||
+ | (a :& b) |
||
+ | (\((a,b,c),d) -> (a,b,c,d)) |
||
+ | |||
+ | a ~&&&& b = FMap |
||
+ | (a :& b) |
||
+ | (\((a,b,c,d),e) -> (a,b,c,d,e)) |
||
+ | |||
+ | a ~&&&&& b = FMap |
||
+ | (a :& b) |
||
+ | (\((a,b,c,d,e),f) -> (a,b,c,d,e,f)) |
||
</haskell> |
</haskell> |
||
+ | and here's a lambda calculus parser |
||
− | Let's check out a recursive grammar of all strings containing only c's of length at least 1 |
||
<haskell> |
<haskell> |
||
+ | |||
− | top' = Fix ((Tok 'c' :& Ref) :| Tok 'c') |
||
+ | |||
− | print $ parse' "cccccc" top' |
||
+ | data Term = Var Char | App Term Term | Abs Char Term deriving Show |
||
− | > True |
||
+ | |||
+ | var = |
||
+ | (Check (\x -> x <= 'z' && x >= 'a')) |
||
+ | |||
+ | app = term ~& term |
||
+ | |||
+ | term = FMap var Var :| abstraction :| parenedTerm |
||
+ | |||
+ | parenedTerm = FMap |
||
+ | (tok '(' ~& term ~&& tok ')') |
||
+ | (\(a,b,c) -> b) |
||
+ | |||
+ | abstraction = FMap |
||
+ | (tok '\\' ~& var ~&& tok '.' ~&&& term) |
||
+ | (\(a,b,c,d) -> Abs b d) |
||
+ | top = FMap |
||
+ | (term ~& tok ';') |
||
+ | fst |
||
+ | |||
+ | main = print $ parse "\\x.x;" top |
||
+ | |||
</haskell> |
</haskell> |
||
+ | |||
+ | [[Category:Code]] |
Latest revision as of 00:07, 22 February 2010
Here's how to embed a context free grammar parser into haskell:
import Maybe
data Grammar a b where
NullParser :: Grammar a b
Check :: (a -> Bool) -> Grammar a a
(:|) :: (Grammar a b) -> (Grammar a b) -> Grammar a b
Push :: a -> (Grammar a b) -> Grammar a b
(:&) :: (Grammar a b) -> (Grammar a c) -> Grammar a (b,c)
FMap :: Grammar a c -> (c -> b) -> Grammar a b
infixl 6 :|
tok x = Check (x==)
parse :: [a] -> Grammar a b -> Maybe b
parse [c] (Check y) = if y c then Just c else Nothing
parse x (g :| g') =
let
r1 = parse x g
r2 = parse x g'
in
if isJust r1 then r1 else r2
parse (x:xs) (g :& g') =
let
r1 = parse xs ((Push x g) :& g')
r2 = parse [] g
r3 = parse (x:xs) g'
in
if isJust r1
then r1
else
if (isJust r2) && (isJust r3)
then Just (fromJust r2, fromJust r3)
else Nothing
parse x (Push c g) = parse (c:x) g
parse x (FMap y f) = parse x y >>= f
parse _ _ = Nothing
infixl 7 ~&
infixl 7 ~&&
infixl 7 ~&&&
infixl 7 ~&&&&
(~&) = (:&)
a ~&& b = FMap
(a :& b)
(\((a,b),c) -> (a,b,c))
a ~&&& b = FMap
(a :& b)
(\((a,b,c),d) -> (a,b,c,d))
a ~&&&& b = FMap
(a :& b)
(\((a,b,c,d),e) -> (a,b,c,d,e))
a ~&&&&& b = FMap
(a :& b)
(\((a,b,c,d,e),f) -> (a,b,c,d,e,f))
and here's a lambda calculus parser
data Term = Var Char | App Term Term | Abs Char Term deriving Show
var =
(Check (\x -> x <= 'z' && x >= 'a'))
app = term ~& term
term = FMap var Var :| abstraction :| parenedTerm
parenedTerm = FMap
(tok '(' ~& term ~&& tok ')')
(\(a,b,c) -> b)
abstraction = FMap
(tok '\\' ~& var ~&& tok '.' ~&&& term)
(\(a,b,c,d) -> Abs b d)
top = FMap
(term ~& tok ';')
fst
main = print $ parse "\\x.x;" top