Unique naming sort-of working

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)

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}

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"))])]))
+
+