Scrap my boilerplate.

That is, convert this all to use Data.Generics, which makes the code a lot
cleaner and avoids needing to autogenerate passthrough functions.
Rename some modules too.

fco/AST.hs

@@ -1,8 +1,8 @@
 -- Data types for occam abstract syntax
 -- This is intended to be imported qualified:
---   import qualified OccamTypes as O
+--   import qualified AST as O
 
-module OccamTypes where
+module AST where
 
 import Data.Generics
 

fco/ASTPasses.hs

@@ -0,0 +1,21 @@
+-- Parses across the AST
+
+module ASTPasses (astPasses) where
+
+import qualified AST as A
+import Data.Generics
+import Control.Monad.State
+
+astPasses =
+  [ ("Silly monad example", numberPass)
+  ]
+
+number :: A.Name -> State Int A.Name
+number (A.Name s) = do
+  i <- get
+  put (i + 1)
+  return $ A.Name (s ++ "." ++ (show i))
+
+numberPass :: A.Process -> A.Process
+numberPass n = evalState (everywhereM (mkM number) n) 0
+

fco/Main.hs

@@ -8,33 +8,19 @@ import System.Console.GetOpt
 import System.IO
 
 import Parse
-import Tree
 import SExpression
 import Pass
-import PhaseSource
-import PhaseIntermediate
-import PhaseOutput
+import PTPasses
+import PTToAST
+import ASTPasses
 
-import TreeToAST
-
-phaseList = [phaseSource, phaseIntermediate, phaseOutput]
-
-doPhases :: [Phase] -> Node -> Progress -> IO Node
-doPhases [] n progress = do return n
-doPhases (p:ps) n progress = do
-  n' <- runPhase p n progress
-  n'' <- doPhases ps n' progress
-  return n''
-
-data Flag = ParseOnly | SOccamOnly | RawParseOnly | ASTOnly | Verbose
+data Flag = ParseOnly | SOccamOnly | Verbose
   deriving (Eq, Show)
 
 options :: [OptDescr Flag]
 options =
   [ Option [] ["parse-tree"] (NoArg ParseOnly) "parse input files and output S-expression parse tree"
   , Option [] ["soccam"] (NoArg SOccamOnly) "parse input files and output soccam"
-  , Option [] ["raw-parse-tree"] (NoArg RawParseOnly) "parse input files and output parse tree"
-  , Option [] ["ast"] (NoArg ASTOnly) "parse input files and output AST"
   , Option ['v'] ["verbose"] (NoArg Verbose) "show more detail about what's going on"
   ]
 
@@ -63,26 +49,33 @@ main = do
   progress $ "Compiling " ++ fn
   progress ""
 
+  progress $ "{{{ Preprocessor"
   preprocessed <- readSource fn
-  progress $ "Preprocessed: "
   progress $ numberedListing preprocessed
-  progress $ ""
+  progress $ "}}}"
 
-  let parsed = parseSource preprocessed
+  progress $ "{{{ Parser"
+  let pt = parseSource preprocessed
+  progress $ show pt
+  progress $ "}}}"
 
   if ParseOnly `elem` opts then do
-      putStrLn $ show (nodeToSExp parsed)
+      putStrLn $ show (nodeToSExp pt)
     else if SOccamOnly `elem` opts then do
-      putStrLn $ show (nodeToSOccam parsed)
-    else if RawParseOnly `elem` opts then do
-      putStrLn $ show parsed
-    else if ASTOnly `elem` opts then do
-      putStrLn $ show (treeToAST parsed)
+      putStrLn $ show (nodeToSOccam pt)
     else do
-      progress $ "Parsed: " ++ show parsed
-      progress ""
+      progress $ "{{{ PT passes"
+      pt' <- runPasses ptPasses progress pt
+      progress $ "}}}"
 
-      out <- doPhases phaseList parsed progress
-      progress ""
-      progress $ "After phases: " ++ show out
+      progress $ "{{{ PT to AST"
+      let ast = ptToAST pt'
+      progress $ show ast
+      progress $ "}}}"
+
+      progress $ "{{{ AST passes"
+      ast' <- runPasses astPasses progress ast
+      progress $ "}}}"
+
+      progress $ "Done"
 

fco/Makefile

@@ -1,24 +1,19 @@
 all: fco
 
 sources = \
-	BaseTransforms.hs \
-	OccamTypes.hs \
+	AST.hs \
+	ASTPasses.hs \
 	Parse.hs \
 	Pass.hs \
-	PhaseIntermediate.hs \
-	PhaseOutput.hs \
-	PhaseSource.hs \
+	PT.hs \
+	PTPasses.hs \
 	SExpression.hs \
-	Tree.hs \
-	TreeToAST.hs \
+	PTToAST.hs \
 	Main.hs
 
 fco: $(sources)
 	ghc -fglasgow-exts -o fco --make Main
 
-BaseTransforms.hs: Tree.hs make-passthrough.py
-	python make-passthrough.py
-
 tests = $(wildcard test*.occ)
 
 test: fco $(tests)

fco/PT.hs

@@ -1,8 +1,10 @@
 -- occam parse tree
 -- This is intended to be imported qualified:
---   import qualified Tree as N
+--   import qualified PT as N
 
-module Tree where
+module PT where
+
+import Data.Generics
 
 data Node =
 -- {{{ BEGIN baseTransformOc
@@ -160,5 +162,5 @@ data Node =
   | CCode String
 -- }}} END
 
-  deriving (Show, Eq)
+  deriving (Show, Eq, Typeable, Data)
 

fco/PTPasses.hs

@@ -0,0 +1,8 @@
+-- Passes across the parse tree
+
+module PTPasses (ptPasses) where
+
+import qualified PT as P
+
+ptPasses = []
+

fco/PTToAST.hs

@@ -1,9 +1,9 @@
 -- Convert the parse tree into the AST
 
-module TreeToAST (treeToAST) where
+module PTToAST (ptToAST) where
 
-import qualified Tree as N
-import qualified OccamTypes as O
+import qualified PT as N
+import qualified AST as O
 
 doName :: N.Node -> O.Name
 doName (N.Name s) = O.Name s
@@ -245,6 +245,6 @@ doProcess n = case n of
   N.PriAltRep _ _ -> O.Alt True $ doAlt n
   N.ProcCall p es -> O.ProcCall (doName p) (map doExpression es)
 
-treeToAST :: N.Node -> O.Process
-treeToAST = doProcess
+ptToAST :: N.Node -> O.Process
+ptToAST = doProcess
 

fco/Parse.hs

@@ -8,7 +8,7 @@ import qualified Text.ParserCombinators.Parsec.Token as P
 import Text.ParserCombinators.Parsec.Language (emptyDef)
 import qualified IO
 
-import qualified Tree as N
+import qualified PT as N
 
 -- -------------------------------------------------------------
 

fco/Pass.hs

@@ -1,50 +1,21 @@
--- Defining passes on the tree
+-- Defining and running passes across some type of tree
 
 module Pass where
 
-import qualified Tree as N
 import Control.Monad.State
 
 type Progress = (String -> IO ())
 
-type ITransform st = N.Node -> State st N.Node
--- This is actually a fraction of a pass: an operation upon the tree.
--- The arguments are:
--- - "next": the next pass to try if this one doesn't match;
--- - "top": the pass to use recursively on subnodes;
--- - the input node.
-type Transform st = ITransform st -> ITransform st -> ITransform st
+type Pass t = t -> t
 
-runTransforms :: st -> [Transform st] -> N.Node -> N.Node
-runTransforms initState passes node = evalState (top node) initState
-  where
-    fail :: ITransform st
-    fail n = error $ "No match for node: " ++ (show n)
+type PassList t = [(String, Pass t)]
 
-    makeTransformList (p:[]) = [p fail top]
-    makeTransformList (p:ps) = p (head rest) top : rest
-      where rest = makeTransformList ps
-
-    passList = makeTransformList passes
-
-    top = head passList
-
-type Pass = N.Node -> N.Node
-
-makePass :: st -> Transform st -> [Transform st] -> Pass
-makePass initState t bases = runTransforms initState (t : bases)
-
-data Phase = Phase String [(String, Pass)]
-
-runPhase :: Phase -> N.Node -> Progress -> IO N.Node
-runPhase (Phase name passes) n progress = do
-  progress $ "Phase: " ++ name
-  runPhase' (reverse passes) n
-  where
-    runPhase' :: [(String, Pass)] -> N.Node -> IO N.Node
-    runPhase' [] n = do return n
-    runPhase' ((name, pass):passes) n = do
-      rest <- runPhase' passes n
-      progress $ "  Pass: " ++ name
-      return $ pass rest
+runPasses :: Show t => PassList t -> Progress -> t -> IO t
+runPasses [] _ d = return d
+runPasses ((name, pass):ps) progress d = do
+  progress $ "{{{ Pass: " ++ name
+  let d' = pass d
+  progress $ show d'
+  progress $ "}}}"
+  runPasses ps progress d'
 

fco/PhaseIntermediate.hs

@@ -1,60 +0,0 @@
--- Intermediate passes
-
-module PhaseIntermediate (phaseIntermediate) where
-
-import qualified Tree as N
-import Pass
-import BaseTransforms
-import Control.Monad.State
-import Data.Map as Map
-
-bases = [baseTransformOc, baseTransformInt]
-
-phaseIntermediate
-  = (Phase "Intermediate mangling"
-      [
-        ("Mark declarations", makePass () markDecls bases)
---       , ("Unique identifiers", makePass (0, Map.empty) uniqueIdentifiers bases)
-      ])
-
-nestDecls :: [(N.Node, N.Node)] -> N.Node -> N.Node
-nestDecls l n = foldl (\a b -> b a) n [N.IntDecl n d | (N.Name n, d) <- l]
-
-markDecls :: Transform ()
-markDecls next top node
-  = case node of
-      -- FIXME same for functions
-      N.Decl d body -> do
-        body' <- top body
-        return $ case d of
-          N.Vars t ns -> nestDecls [(n, t) | n <- ns] body'
-          N.Is (N.Name n) _ -> N.IntDecl n d body'
-          N.IsType (N.Name n) _ _ -> N.IntDecl n d body'
-          N.ValIs (N.Name n) _ -> N.IntDecl n d body'
-          N.ValIsType (N.Name n) _ _ -> N.IntDecl n d body'
-          N.DataType (N.Name n) _ -> N.IntDecl n d body'
-          N.Protocol (N.Name n) _ -> N.IntDecl n d body'
-          N.FuncIs (N.Name n) _ _ _ -> N.IntDecl n d body'
-          N.Retypes (N.Name n) _ _ -> N.IntDecl n d body'
-          N.ValRetypes (N.Name n) _ _ -> N.IntDecl n d body'
-          N.Reshapes (N.Name n) _ _ -> N.IntDecl n d body'
-          N.ValReshapes (N.Name n) _ _ -> N.IntDecl n d body'
-          _ -> error ("Unhandled type of declaration: " ++ (show d))
-      _ -> next node
-
-uniqueIdentifiers :: Transform (Int, Map.Map String String)
-uniqueIdentifiers next top node
-  = case node of
-      N.IntDecl name def body -> do
-        (n, ids) <- get
-        let newname = name ++ "_" ++ (show n)
-        put (n + 1, Map.insert name newname ids)
-        def' <- top def
-        body' <- top body
-        modify (\(n, _) -> (n, ids))
-        return $ N.IntDecl newname def' body'
-      N.Name s -> do
-        (_, ids) <- get
-        return $ if Map.member s ids then N.Name (Map.findWithDefault "" s ids) else error ("Unknown identifier: " ++ s)
-      _ -> next node
-

fco/PhaseOutput.hs

@@ -1,21 +0,0 @@
--- C output passes
-
-module PhaseOutput (phaseOutput) where
-
-import Tree
-import Pass
-import BaseTransforms
-
-bases = [baseTransformOc, baseTransformInt, baseTransformC]
-
-phaseOutput
-  = (Phase "C output"
-      [
-        ("Convert expressions", makePass () convExpressions bases)
-      ])
-
-convExpressions :: Transform ()
-convExpressions next top node
-  = case node of
-    _ -> next node
-

fco/PhaseSource.hs

@@ -1,31 +0,0 @@
--- Source-rewriting passes
-
-module PhaseSource (phaseSource) where
-
-import qualified Tree as N
-import Pass
-import BaseTransforms
-import Control.Monad.State
-
-bases = [baseTransformOc]
-
-phaseSource
-  = (Phase "Source rewriting"
-      [
-        ("Simplify", makePass () simplify bases),
-        ("C-ify identifiers", makePass () cifyIdentifiers bases)
-      ])
-
-simplify :: Transform ()
-simplify next top node
-  = case node of
-      -- FIXME rewrite stuff like N.FuncIs -> N.Func
-      -- FIXME could we even rewrite procs and functions to the same thing?
-      _ -> next node
-
-cifyIdentifiers :: Transform ()
-cifyIdentifiers next top node
-  = case node of
-      N.Name n -> return $ N.Name [if c == '.' then '_' else c | c <- n]
-      _ -> next node
-

fco/SExpression.hs

@@ -3,7 +3,7 @@
 module SExpression where
 
 import List
-import qualified Tree as N
+import qualified PT as N
 
 data SExp = Item String | List [SExp]
 

fco/make-passthrough.py

@@ -1,82 +0,0 @@
-#!/usr/bin/python
-# Generate the base transforms from the data type definition in Tree.
-
-import os, sys, re
-
-def die(*s):
-	print >>sys.stderr, "Fatal: " + "".join(map(str, s))
-	sys.exit(1)
-
-def update_def(func, f, newf):
-	newf.write("\n" + func + " :: Transform st\n")
-	newf.write(func + " next top node\n")
-	newf.write("  = case node of\n")
-	while True:
-		s = f.readline()
-		if s == "":
-			die("Unexpected EOF during Node definition")
-		elif s.strip().startswith("-- }}} END"):
-			break
-
-		s = s.strip()
-		if s == "" or s.startswith("--"):
-			continue
-		s = s.replace("| ", "")
-
-		fields = s.split()
-		name = "N." + fields[0]
-		args = fields[1:]
-
-		lhs = []
-		lines = []
-		rhs = []
-		i = 1
-		for arg in args:
-			n = "a" + str(i)
-			i += 1
-
-			lhs.append(n)
-			var = "v" + n
-			if arg == "Node":
-				lines.append(var + " <- top " + n)
-				rhs.append(var)
-			elif arg == "[Node]":
-				lines.append(var + " <- mapM top " + n)
-				rhs.append(var)
-			else:
-				rhs.append(n)
-
-		space = ""
-		if lhs != []:
-			space = " "
-		newf.write("      " + name + space + " ".join(lhs) + " -> do\n")
-		for l in lines:
-			newf.write("        " + l + "\n")
-		newf.write("        return $ " + name + space + " ".join(rhs) + "\n")
-	newf.write("      _ -> next node\n")
-
-def main():
-	f = open("Tree.hs")
-	newf = open("BaseTransforms.hs", "w")
-
-	newf.write("""-- Base transforms
--- Automatically generated from Tree.hs -- do not edit!
-
-module BaseTransforms where
-
-import qualified Tree as N
-import Pass
-import Control.Monad
-""")
-
-	while 1:
-		s = f.readline()
-		if s == "":
-			break
-		if s.startswith("-- {{{ BEGIN"):
-			ss = s.strip().split()
-			update_def(ss[3], f, newf)
-	f.close()
-	newf.close()
-
-main()