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

[CK Kashyap]

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 <stephen.tetley at gmail.com>
> Cc: haskell-cafe at 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 at haskell.org
> http://www.haskell.org/mailman/listinfo/haskell-cafe