On Thu, Apr 05, 2007 at 12:14:52AM +0100, Joel Reymont wrote:
> Folks,
>
> I have very uniform Parsec code like this and I'm wondering if I can
> derive it using TemplateHaskell or DrIFT or some other tool. Any ideas?
>
> Note that
>
> 1) The reserved word matches the constructor
>
> 2) No arguments equals no parens
>
> 3) More than one argument is separated with a comma
>
> 4) For every invocation of numExpr, strExpr or boolExpr, the type of
> the constructor argument is NumExpr, StrExpr and BoolExpr respectively.
>
> This is just a handful of functions and I have to tackle about 100
> more, thus my asking :-).
>
> Thanks, Joel
Data.Derive can do this. In an attempt to avoid munging the relevent
files they are attached.
[EMAIL PROTECTED]:/tmp$ ghci -fth -v0 -i/usr/local/src/derive -e '$(
_derive_print_instance makeJoelR '"''"'Foo )' Sample.hs
instance JoelR Main.Foo
where parse = choice [(>>) (reserved ['A']) ((>>) (char '(') ((>>=) parse
(\a0 -> (>>) (char ')') (return (Main.A a1))))),
(>>) (reserved ['B']) ((>>) (char '(') ((>>=) parse
(\a0 -> (>>) (char ',') ((>>=) parse (\a1 -> (>>)
(char ')') (return (Main.B a1 a2))))))),
(>>) (reserved ['C']) (return Main.C)]
Not pretty code, but it will work. (Future plans include adding a
prefix -> infix translator to the optimizer.)
http://www.cs.york.ac.uk/fp/darcs/derive
Stefan
import Text.ParserCombinators.Parsec
import Data.Derive.JoelR
import Data.Derive.TH
class JoelR a where parse :: CharParser s a
data NumExpr = Dummy_ -- I don't know the constr
numExpr = undefined
instance JoelR NumExpr where parse = numExpr
data Foo = A NumExpr | B Foo Foo | C
module Data.Derive.JoelR where
import Data.Derive
import Data.Derive.Peephole
import Data.List
makeJoelR = Derivation drv "JoelR"
drv dat@(DataDef name arity ctors) =
simple_instance "JoelR" dat [funN "parse" [ sclause [] body ] ]
where
body = l1 "choice" $ lst [ clause con | con <- ctors ]
clause con = l1 "reserved" (lit (trim (ctorName con))) >>: args con (ctorArity con)
trim = reverse . takeWhile (/= '.') . reverse
args ct 0 = return' (ctp ct 'a')
args ct k = l1 "char" (lit '(') >>: args' ct k 0
args' ct remn seen = l0 "parse" >>=: (('a' : show seen) ->: args'' ct (remn-1) (seen+1))
args'' ct 0 seen = l1 "char" (lit ')') >>: return' (ctp ct 'a')
args'' ct k seen = l1 "char" (lit ',') >>: args' ct k seen
_______________________________________________
Haskell-Cafe mailing list
Haskell-Cafe@haskell.org
http://www.haskell.org/mailman/listinfo/haskell-cafe
