----- Begin Included Message -----
Date: Tue, 7 Sep 93 12:08:23 -0400
From: [EMAIL PROTECTED]
To: [EMAIL PROTECTED]
Subject: Looking for examples of functional imperative programming
In response to Don Smith's request, here follows my version of a
Gensym monad and real code that uses it. This is syntactic
manipulation code that needs to invent new variable names for the
output terms. Constructed terms are returned by calling the monad's
`unit' function; constructed subterms are passed on into the rest of
the program by the monad's `>>' operator. The main burden is having
to invent a name for each intermediate result, rather than
substituting the imperative function in its place in the output as one
can do in Lisp or Standard ML.
I don't have handy any examples of hardcore reference-cell hacking a la
impure Standard ML, but I think such code would exhibit the same
limitation: one loses the anonymous value-passing implicit in the
functional-expression notation. In my opinion, this drawback can be
fixed with syntactic sugar of a sort that has heretofore been excluded
by the functional programming community's dogma that higher-order
functions suffice for all such purposes.
A further problem is combining more than one imperative construct in a
single program. I know that David King and Phil Wadler have worked on
this problem, but I don't know the current state of their work. Here
again I think cautious optimism is in order.
The Glasgow Haskell compiler is written in Haskell, and uses various
imperative programming techniques throughout. It's available for
anonymous ftp from nebula.systemsz.cs.yale.edu, as well as from
glasgow. They have a C interface. Sheng Liang here at Yale has
written an X interface that's available in the Yale Haskell release
(at the same ftp site).
-- Dan Rabin ([EMAIL PROTECTED])
module Gensym(NameUser,
newNameSupply,
gensym,
regensym,
(>>),
unit)
where
data NameUser a = NameUser (Integer -> (a, Integer))
newNameSupply :: NameUser a -> a
newNameSupply (NameUser f) = let (x, n) = f 0
in x
gensym :: String -> NameUser String
gensym baseName = NameUser (\ n ->
(baseName ++ "-" ++ show n,
n + 1))
regensym :: String -> NameUser String
regensym oldName = let baseName = takeWhile (/= '-') oldName
in gensym baseName
(>>) :: NameUser a -> (a -> NameUser b) -> NameUser b
(NameUser f) >> g = NameUser (\ n -> let (x, n') = f n
NameUser f' = g x
in f' n')
unit :: a -> NameUser a
unit x = NameUser (\ n -> (x, n))
----------------------------------------------------------------------
{-
CPS transform from Sabry-Felleisen `Reasoning...' tech report.
Dan Rabin Tue Aug 17 12:53:48 1993
-}
{-**********************************************************************-}
module SFCPS' where
import Terms
import Gensym
convertTerm :: Name -> Term a -> NameUser (Term a)
convertTerm cname (Val val)
= convertValue val >> (\ term ->
unit (App (Val (Var cname)) term))
convertTerm cname (App term1 term2)
= convertApp term1 term2 []
where
convertApp (Val (Var name)) (Val val) ectxt
= convertContext cname ectxt >> (\ t1 ->
convertValue val >> (\ t2 ->
unit (App (App (Val (Var name)) t1) t2)))
convertApp (Val (Const x)) (Val val) ectxt
= convertContext cname ectxt >> (\ t1 ->
convertValue val >> (\ t2 ->
unit (App (App (Val (Const x)) t1) t2)))
convertApp (Val (Abs name body)) (Val val) ectxt
= convertTerm cname (intoEContext body ectxt) >> (\ t1 ->
convertValue val >> (\ t2 ->
unit (App (Val (Abs name t1)) t2)))
convertApp (Val val) (App term1 term2) ectxt
= convertApp term1 term2 (ArgECtxt val : ectxt)
convertApp (App term1 term2) term3 ectxt
= convertApp term1 term2 (FunECtxt term3 : ectxt)
convertValue :: Value a -> NameUser (Term a)
convertValue (Var name) = unit (Val (Var name))
convertValue (Const x) = unit (Val (Const x))
convertValue (Abs name body)
= gensym "k" >> (\ cname ->
convertTerm cname body >> (\ t1 ->
unit (Val (Abs cname (Val (Abs name t1))))))
convertContext :: Name -> EContext a -> NameUser (Term a)
convertContext cname [] = unit (Val (Var cname))
convertContext cname (ArgECtxt (Var name) : ectxt)
= convertContext cname ectxt >> (\ t1 ->
unit (App (Val (Var name)) t1))
convertContext cname (ArgECtxt (Const x) : ectxt)
= convertContext cname ectxt >> (\ t1 ->
unit (App (Val (Const x)) t1))
convertContext cname (ArgECtxt (Abs name body) : ectxt)
= convertTerm cname (intoEContext body ectxt) >> (\ t1 ->
unit (Val (Abs name t1)))
convertContext cname (FunECtxt term : ectxt)
= gensym "v" >> (\ vname ->
convertTerm cname (intoEContext (App (Val (Var vname)) term) ectxt)
>> (\ t2 ->
unit (Val (Abs vname t2))))
invertTerm :: CPSTerm a -> NameUser (Term a)
invertTerm (CPSContApp k w)
= invertCont k >> (\ t1 ->
invertVal w >> (\ t2 ->
unit (intoEContext t2 t1)))
invertVal :: CPSVal a -> NameUser (Term a)
invertVal (CPSVar name) = unit (Val (Var name))
invertVal (CPSFun name (CPSK name'))
= gensym "x" >> (\ name ->
unit (Val (Abs name (Val (Var name)))))
invertVal (CPSFun cname (CPSValApp w k))
= gensym "x" >> (\ name ->
invertTerm (CPSContApp (CPSValApp w k) (CPSVar name)) >> (\ t1 ->
unit (Val (Abs name t1))))
invertCont :: CPSCont a -> NameUser (EContext a)
invertCont (CPSK name) = unit []
invertCont (CPSValApp (CPSVar name) k)
= invertCont k >> (\ ectxt ->
unit (ArgECtxt (Var name) : ectxt))
invertCont (CPSValApp (CPSFun cname k1) k2)
= substCont k2 cname k1 >> (\ k2' ->
invertCont k2')
invertCont (CPSCont name t)
= invertTerm t >> (\ t1 ->
unit [ArgECtxt (Abs name t1)])
substCont :: CPSCont a -> Name -> CPSCont a -> NameUser (CPSCont a)
substCont t1 cname t2
= let fvs = freeVars t1
subst' (CPSK cname') env | cname == cname'
= unit t1
subst' (CPSK cname') env
= unit (CPSK (maybeRename cname' env))
subst' (CPSValApp w k) env
= subst'' w env >> (\ w' ->
subst' k env >> (\ k' ->
unit (CPSValApp w' k')))
subst' (CPSCont name t) env | cname == name
= unit (CPSCont name t)
subst' (CPSCont name t) env | any (== name) fvs
= regensym name >> (\ name' ->
subst''' t ((name := name') : env) >> (\ t' ->
unit (CPSCont name' t')))
subst' (CPSCont name t) env
= subst''' t env >> (\ t' ->
unit (CPSCont name t'))
subst'' (CPSVar name) env
= unit (CPSVar (maybeRename name env))
subst'' (CPSFun cname' k) env | cname == cname'
= unit (CPSFun cname' k)
subst'' (CPSFun cname' k) env | any (== cname') fvs
= regensym cname' >> (\ cname'' ->
subst' k ((cname' := cname'') : env) >> (\ k' ->
unit (CPSFun cname'' k')))
subst'' (CPSFun cname' k) env
= subst' k env >> (\ k' ->
unit (CPSFun cname' k'))
subst''' (CPSContApp k w) env
= subst' k env >> (\ k' ->
subst'' w env >> (\ w' ->
unit (CPSContApp k' w')))
in subst' t2 []
maybeRename :: Name -> [Assoc Name Name] -> Name
maybeRename name env = loop env
where
loop [] = name
loop ((name' := name'') : env)
= if name == name'
then name''
else loop env
freeVars :: CPSCont a -> [Name]
freeVars c = freevars' c
where
freevars' (CPSK cname) = [cname]
freevars' (CPSValApp w k) = nub (freevars'' w ++ freevars' k)
freevars' (CPSCont name t) = filter (/= name) (freevars''' t)
freevars'' (CPSVar name) = [name]
freevars'' (CPSFun cname k) = filter (/= cname) (freevars' k)
freevars''' (CPSContApp k w) = nub (freevars'' w ++ freevars' k)
tester term = toString (newNameSupply (convertTerm "k" term) :: Term Int)
var name = Val (Var name)
lam name body = Val (Abs name body)
test1 = tester (Val (Abs "x" (Val (Var "x"))))
test2 = tester (App (Val (Abs "x" (App (Val (Var "x")) (Val (Var "x")))))
(Val (Abs "x" (App (Val (Var "x")) (Val (Var "x"))))))
test3 = tester (App (App (var "a") (var "b")) (App (var "c") (var "d")))
{-**********************************************************************-}
module Terms(Name(..),
Term(..),
Value(..),
CPSTerm(..),
CPSVal(..),
CPSCont(..),
ContextStep(..),
Context(..),
EContextStep(..),
EContext(..),
isValue,
intoContext,
intoEContext,
toString)
where
type Name = String
data Term a = Val (Value a)
| App (Term a) (Term a)
deriving Text
data Value a = Var Name
| Const a
| Abs Name (Term a)
deriving Text
data CPSTerm a = CPSContApp (CPSCont a) (CPSVal a)
data CPSVal a = CPSVar Name
| CPSFun Name (CPSCont a)
data CPSCont a = CPSK Name
| CPSValApp (CPSVal a) (CPSCont a)
| CPSCont Name (CPSTerm a)
-- Define (linear) contexts as list of incremental wrappings-in-terms
-- proceeding from the hole upwards.
data ContextStep a = AbsCtxt Name
| LAppCtxt (Term a)
| RAppCtxt (Term a)
type Context a = [ContextStep a]
data EContextStep a = FunECtxt (Term a)
| ArgECtxt (Value a)
type EContext a = [EContextStep a]
isValue :: Term a -> Bool
isValue (Val x) = True
isValue (App term1 term2) = False
intoContext :: Term a -> Context a -> Term a
intoContext term = foldl intoContextStep term
where
intoContextStep term (AbsCtxt name) = Val (Abs name term)
intoContextStep term (LAppCtxt term') = App term term'
intoContextStep term (RAppCtxt term') = App term' term
intoEContext :: Term a -> EContext a -> Term a
intoEContext term = foldl intoEContextStep term
where
intoEContextStep term (FunECtxt term') = App term term'
intoEContextStep term (ArgECtxt val) = App (Val val) term
-- evalMapTerm :: Term a -> (Term a -> EContext a -> b) -> b
toString :: (Text a) => Term a -> String
toString (Val (Var name)) = name
toString (Val (Const a)) = show a
toString (Val (Abs name body)) = "\\" ++ name ++ "." ++ toString body
toString (App term1 term2) = "(" ++ toString term1 ++ " " ++ toString term2 ++ ")"
----- End Included Message -----
