From 763f735a379237383dba60bc91e4963a09ad9eca Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Wed, 18 Oct 2006 03:35:13 +0000 Subject: [PATCH] Unique naming sort-of working --- fco/ASTPasses.hs | 79 ++++++++++++++++++--------------- fco/doc/writeup.tex | 9 ++++ fco/experiments/UniqueNaming.hs | 70 +++++++++++++++++++++++++++++ 3 files changed, 122 insertions(+), 36 deletions(-) create mode 100644 fco/experiments/UniqueNaming.hs diff --git a/fco/ASTPasses.hs b/fco/ASTPasses.hs index ae11bd5..4efdbd2 100644 --- a/fco/ASTPasses.hs +++ b/fco/ASTPasses.hs @@ -1,6 +1,7 @@ -- Parses across the AST -module ASTPasses (astPasses) where +--module ASTPasses (astPasses) where +module ASTPasses where import qualified AST as A import List @@ -29,46 +30,52 @@ astPasses = , ("C-style names", cStyleNamesPass) ] -{- -numberPass :: A.Process -> A.Process -numberPass n = evalState (everywhereM (mkM (number `extM` number')) n) 0 +type UniqueState = (Int, [(String, String)]) +type UniqueM t = State UniqueState t + +uniqueNamesPass :: A.Process -> A.Process +uniqueNamesPass p = evalState (doAny p) (0, []) where - number :: A.Name -> State Int A.Name - number (A.Name s) = do - i <- get - put (i + 1) - return $ A.Name (s ++ "." ++ (show i)) + doAny :: Data t => t -> UniqueM t + doAny = doGeneric `extM` doName `extM` doProcess `extM` doValueProcess `extM` doStructured - number' :: A.Tag -> State Int A.Tag - number' (A.Tag s) = do - i <- get - put (i + 1) - return $ A.Tag (s ++ "." ++ (show i)) --} + doGeneric :: Data t => t -> UniqueM t + doGeneric = gmapM doAny -type Transform t = t -> t +-- this is wrong for "v IS v:" -- name shouldn't come into scope until after the spec + withSpec :: Data t => A.Specification -> t -> UniqueM t + withSpec (A.Name n, _) p = do + (_, vars) <- get + (count, vars) <- get + put (count + 1, (n, n ++ "." ++ show count) : vars) + p' <- doGeneric p + (count', _) <- get + put (count', vars) + return p' -everyContext :: Data a => (forall b. Data b => (c, b) -> (c, b)) -> c -> a -> a -everyContext f c x = gmapT innerT x' - where - (c', x') = f (c, x) - innerT xi = everyContext f c' xi + doProcess :: A.Process -> UniqueM A.Process + doProcess p = case p of + A.ProcSpec s _ -> withSpec s p + otherwise -> doGeneric p -uniqueNamesPass :: Transform A.Process -uniqueNamesPass n = everyContext doAny [] n - where - doAny :: Data t => Transform ([String], t) - doAny = (mkT doP) `extT` doV `extT` doS `extT` doN - doP :: Transform ([String], A.Process) - doP (c, p) = case p of - A.ProcSpec ((A.Name n), _) _ -> (n : c, p) - otherwise -> (c, p) - doV :: Transform ([String], A.ValueProcess) - doV = undefined - doS :: Transform ([String], A.Structured) - doS = undefined - doN :: Transform ([String], A.Name) - doN (c, A.Name s) = (c, A.Name (s ++ "=" ++ (concat $ intersperse "," c))) + doValueProcess :: A.ValueProcess -> UniqueM A.ValueProcess + doValueProcess p = case p of + A.ValOfSpec s _ -> withSpec s p + otherwise -> doGeneric p + + doStructured :: A.Structured -> UniqueM A.Structured + doStructured p = case p of + A.Spec s _ -> withSpec s p + otherwise -> doGeneric p + + doName :: A.Name -> UniqueM A.Name + doName (A.Name s) = do + (_, vars) <- get + let s' = case lookup s vars of + Just n -> n + Nothing -> "(not-declared-" ++ s ++ ")" + --Nothing -> error $ "Name " ++ s ++ " not declared before use" + return $ A.Name s' cStyleNamesPass :: A.Process -> A.Process cStyleNamesPass = everywhere (mkT doName) diff --git a/fco/doc/writeup.tex b/fco/doc/writeup.tex index a5cadf3..dac5598 100644 --- a/fco/doc/writeup.tex +++ b/fco/doc/writeup.tex @@ -173,10 +173,19 @@ replicators and specifications, such as \verb|IF| and \verb|ALT| processes; I couldn't combine generic operations over these with others, though (see \ref{gen-par-prob}). +Some things are simplified in the AST when compared with the grammar: +channels are just variables, for example. + +Need to pass metadata through to the AST. + \section{Generic strategies} Need to walk over the tree, tracking state. +Unique naming comes out nicer in Haskell than in Scheme, since I can +just use monads and generic transformations, and don't need to write out +all the productions again just to add an extra argument. + \section{C generation} \section{Future work} diff --git a/fco/experiments/UniqueNaming.hs b/fco/experiments/UniqueNaming.hs new file mode 100644 index 0000000..3d171bd --- /dev/null +++ b/fco/experiments/UniqueNaming.hs @@ -0,0 +1,70 @@ +-- Demonstrate how to do unique naming. + +import Control.Monad.State +import Data.Generics +import Data.List + +-- + +data Name = Name String + deriving (Show, Eq, Typeable, Data) + +data Direction = Input Name | Output Name + deriving (Show, Eq, Typeable, Data) + +data Process = Declare Name Process | Use Direction | Seq [Process] + deriving (Show, Eq, Typeable, Data) + +-- + +type UniqueState = (Int, [(String, String)]) +type UniqueM t = State UniqueState t + +uniquelyName :: Process -> Process +uniquelyName p = evalState (doAny p) (0, []) + +doAny :: Data t => t -> UniqueM t +doAny = doGeneric `extM` doName `extM` doProcess + +doGeneric :: Data t => t -> UniqueM t +doGeneric = gmapM doAny + +doProcess :: Process -> UniqueM Process +doProcess p = case p of + Declare (Name n) _ -> do + (count, vars) <- get + put (count + 1, (n, n ++ "." ++ show count) : vars) + p' <- doGeneric p + (count', _) <- get + put (count', vars) + return p' + otherwise -> doGeneric p + +doName :: Name -> UniqueM Name +doName (Name s) = do + (count, vars) <- get + let s' = case lookup s vars of + Just n -> n + Nothing -> error $ "Name " ++ s ++ " not declared before use" + return $ Name s' + +-- + +demo :: Process -> IO () +demo p = do + putStrLn $ show p + let p' = uniquelyName p + putStrLn $ show p' + putStrLn "" + +main :: IO () +main = do + demo $ Declare (Name "foo") (Use (Input (Name "foo"))) + demo $ Declare (Name "a") (Seq [Use (Input (Name "a")), + Use (Output (Name "a"))]) + demo $ Declare (Name "a") (Declare (Name "b") (Seq [Use (Input (Name "a")), + Use (Input (Name "b")), + Declare (Name "b") (Seq [Use (Input (Name "a")), + Use (Input (Name "b"))])])) + +