Re: [Haskell-cafe] Haskell implementation of ideas from StandardML as a Metaprogramming language

Thank you very much Stephen ... I'll try and work on the doc plus the code you've sent to understand it. If you do find the parser combinators, please do send it to me. Thanks and Regards, Kashyap ----- Original Message ----

From: Stephen Tetley Cc: haskell-cafe@haskell.org Sent: Fri, January 15, 2010 1:08:20 AM Subject: Re: [Haskell-cafe] Haskell implementation of ideas from StandardML as a Metaprogramming language

Hello Kashyap

I can do MSL and Region, maybe I did the parser combinators but I can't find them at the moment.

I tried to keep the code close to the original SML, so as Haskell code its not pretty. Not having quasiquote was a problem.

Best wishes

Stephen

-------------------------------------------------------------------------------- -- MSL

module MSL where

type Expr = String type Predicate = Expr type Statement = String type Fieldname = String

data Bitsource = Source Expr Expr deriving Show

newbitsource a i = Source a i

initbs (Source _ i) = i ++ " = 0;"

getByte (Source a i) = a ++ "[" ++ i ++ "/8]"

getNthByte :: Bitsource -> Int -> Expr getNthByte (Source a i) n | n == 0 = a ++ "[" ++ i ++ "/8]" | otherwise = a ++ "[" ++ i ++ "/8+" ++ show n ++ "]"

advanceByte (Source a i) = i ++ " = " ++ i ++ "-(" ++ i ++ "%8)+8;"

advanceNBytes (Source a i) n | n == 0 = "" | otherwise = i ++ " = " ++ i ++ "-(" ++ i ++ "%8)+(8*" ++ show n++");"

data Recordfield = Field Expr [Fieldname] deriving Show

recordptr :: Expr -> Recordfield recordptr e = Field e []

subfield :: Recordfield -> Fieldname -> Recordfield subfield (Field e fl) f = Field e (f:fl)

deref :: Recordfield -> Expr deref (Field e fl) = "(*" ++e++ ")" ++ concat ( map cojoin (reverse fl) ) where cojoin :: Fieldname -> String cojoin s = "." ++ s

type Message = Bitsource -> Recordfield -> Statement -> Statement

infield :: Fieldname -> Message -> Message infield f m src tgt = m src (subfield tgt f)

c_if :: Expr -> Statement -> Statement -> Statement c_if e s1 s2 = if e=="1" || e=="(1)" then s1 else "if("++e++"){" ++ s1 ++ "}" ++ if s2 /= "" then "else {" ++ s2 ++ "}" else ""

seqmsg :: [Message] -> Message seqmsg (m:ml) src tgt s = (m src tgt "error_action();") ++ (seqmsg ml src tgt s) seqmsg [] _ _ _ = ""

asc2Int :: Int -> (Int,Int) -> Message asc2Int w (lo,hi) src tgt s = c_if ("inrange(" ++ (getByte src) ++ ", " ++ (ms w) ++ ", " ++ (ms lo) ++ ", " ++ (ms hi)) "" s where ms n = show n

alt :: [Message] -> Message alt (m:ml) src tgt s = m src tgt (alt ml src tgt s)

delim :: Expr -> Message delim e src tgt s = "if (" ++ getByte src ++ " == " ++ e ++")" ++ advanceByte src

rangex :: Int -> Int -> [Int] rangex i j | i > j = [] | otherwise = (i:(rangex (i+1) j))

c_and [] = "" c_and [pred] = "(" ++ pred ++ ")" c_and (pred1:pred2:preds) = "(" ++ pred1 ++ " && " ++ c_and (pred2:preds) ++ ")"

asc :: String -> String -> Message asc chars value src tgt s = c_if "" (deref tgt ++ " == " ++ value ++ ";" ) s

skip :: Int -> Message skip n src tgt s = (deref tgt) ++ "= 1;" ++ (advanceNBytes src n)

--------------------------------------------------------------------------------

bs = newbitsource "A" "bit" f = recordptr "target"

main = delim "6" bs f "abort();"

to_confidence = alt [ asc "HH" "High" , asc "MM" "Medium" , asc "LL" "Low" , asc "NN" "None" ]

-------------------------------------------------------------------------------- -- Region

-- This one doesn't work properly - -- CPoints are difficult to manipulate as strings, hence the `hasVar` -- problems, it gives some idea of the method though.

module Region where

import Data.Char ( isAlpha ) import Data.List ( foldl' )

-- Prolog type CExpr = String type CPred = String type CFloat = Float

infixr 6 ++& (++&) :: Show a => String -> a -> String s ++& a = s ++ show a

sqrdist _ = ""

add :: CPoint -> CPoint -> CPoint add a b = a ++ "+" ++ b

sub :: CPoint -> CPoint -> CPoint sub a b = a ++ "-" ++ b

hasVar :: CExpr -> Bool hasVar = any isAlpha

cfst :: CPoint -> CExpr cfst a | hasVar a = a ++ ".x" | otherwise = "1.1"

csnd :: CPoint -> CExpr csnd a | hasVar a = a ++".y" | otherwise = "2.2"

pt :: (CFloat,CFloat) -> CPoint pt = show

intersect :: [Region] -> Region intersect (r:rs) = foldl' (/\) r rs intersect [] = error $ "intersect on empty list"

-- presentation

type CPoint = CExpr type Region = CPoint -> CPred

circle :: CFloat -> Region circle n = \p -> "(" ++ sqrdist p ++ "<" ++& n ++ "*" ++& n ++ ")"

halfplane :: CPoint -> CPoint -> Region halfplane a b = \p -> "(" ++ zcross (a `sub` p) (b `sub` a) ++ " > 0.0)" where zcross e1 e2 = "(" ++ cfst e1 ++ "*" ++ csnd e2 ++ "-" ++ csnd e2 ++ "*" ++ cfst e1 ++ ")"

(/\) :: Region -> Region -> Region r1 /\ r2 = \p -> "(" ++ r1 p ++ " && " ++ r2 p ++ ")"

(\/) :: Region -> Region -> Region r1 \/ r2 = \p -> "(" ++ r1 p ++ " || " ++ r2 p ++ ")"

at :: Region -> CPoint -> Region r `at` p0 = \p -> r (p `sub` p0)

convexPoly :: [CPoint] -> Region convexPoly (p:ps) = intersect (zipWith halfplane ([p] ++ ps) (ps ++ [p]))

tightZone :: CPoint -> CPred tightZone = (convexPoly [pt (0.0,5.0), pt (118.0,32.0), pt (118.0,62.0), pt (0.0,25.0) ]) \/ (convexPoly [pt (118.0,32.0), pt (259.0,5.0), pt (259.0, 25.0), pt (118.0,62.0)])

main = tightZone e1 where e1::CExpr e1 = "p" _______________________________________________ Haskell-Cafe mailing list Haskell-Cafe@haskell.org http://www.haskell.org/mailman/listinfo/haskell-cafe