Added an automatically-generated OrdAST module that provides an ordering for AST elements, ignoring Meta tags

GenOrdAST.hs

@@ -0,0 +1,116 @@
+{-
+Tock: a compiler for parallel languages
+Copyright (C) 2007  University of Kent
+
+This program is free software; you can redistribute it and/or modify it
+under the terms of the GNU General Public License as published by the
+Free Software Foundation, either version 2 of the License, or (at your
+option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License along
+with this program.  If not, see <http://www.gnu.org/licenses/>.
+-}
+
+-- | Generates the OrdAST module.  Template Haskell was a bit too heavyweight
+-- for this.  Uses Data.Generics to pick out all the constructors for the
+-- given types, skip Meta tags and write out the OrdAST module
+-- (to stdout).
+module GenOrdAST where
+
+import Control.Monad.State
+import Control.Monad.Writer
+import Data.Generics
+import Data.List
+
+import qualified AST as A
+import Metadata
+
+genHeader :: [String]
+genHeader = [
+  -- Turn on lots of warnings and make them errors to help ensure our generated code is right:
+
+  "{-# OPTIONS_GHC -Werror -fwarn-overlapping-patterns -fwarn-unused-matches -fwarn-unused-binds -fwarn-incomplete-patterns #-}"
+ ,"-- | Contains Ord instances for AST elements."
+ ,"-- NOTE: This file is auto-generated by the GenOrdAST program, and should not be edited directly."
+ ,"module OrdAST where"
+ ,""
+ ,"import qualified AST"
+ ,"import Utils"
+ ,""
+ ]
+
+-- | Here's the idea for easily building a compare function.  Go through in ascending order.
+-- Match A vs A in detail.  For A vs _ give LT, and for _ vs A give GT.  Then repeat for B, C, etc
+-- But for the last item, do not give the LT and GT matches!
+ordFor :: forall a. (Data a, Typeable a) => a -> [String]
+ordFor x = process $ map processConstr $ dataTypeConstrs $ dataTypeOf x
+  where
+    process :: [(String, String, String, [String])] -> [String]
+    process [] = []
+    process items =
+      ["instance Ord " ++ (dataTypeName $ dataTypeOf x) ++ " where"]
+      ++ concat [ [ "  compare (" ++ name ++ headL ++ ") (" ++ name ++ headR ++ ") = " ++
+                    --Shortcut:
+                    if null comparisons then "EQ" else
+                      "combineCompare [" ++ concat (intersperse "," comparisons) ++ "]"
+                  ] ++ if isLast then [] else
+                  [ "  compare (" ++ name ++ " {}) _ = LT"
+                  , "  compare _ (" ++ name ++ " {}) = GT"]
+                 | (isLast, (name, headL, headR, comparisons)) <- zip (repeat False) (init items) ++ [(True,last items)] ]
+    nextVar :: State Int String
+    nextVar = do n <- get
+                 put (n + 1)
+                 return $ "x" ++ show n
+  
+    doNormal :: forall a. a -> WriterT (String, String, [String]) (State Int) a
+    doNormal x = do v <- lift nextVar
+                    tell (" " ++ v ++ " ", " " ++ v ++ "' ", ["compare " ++ v ++ " " ++ v ++ "'"])
+                    return x
+    
+    doMeta :: Meta -> WriterT (String, String, [String]) (State Int) Meta
+    doMeta m = tell (" _ ", " _ ", []) >> return m
+  
+    processConstr :: Constr -> (String, String, String, [String])
+    processConstr c = let (x,y,z) = flip evalState 0 $ execWriterT $ gmapM (doNormal `extM` doMeta) $ (fromConstr c :: a) in
+                      ("AST." ++ showConstr c, x, y, z)
+  
+items :: [String]
+items = concat
+ [ordFor (u :: A.Actual)
+ ,ordFor (u :: A.Alternative)
+ ,ordFor (u :: A.ArrayConstr)
+ ,ordFor (u :: A.ArrayElem)
+ ,ordFor (u :: A.ChanAttributes)
+ ,ordFor (u :: A.Choice)
+ ,ordFor (u :: A.Dimension)
+ ,ordFor (u :: A.Expression)
+ ,ordFor (u :: A.ExpressionList)
+ ,ordFor (u :: A.Formal)
+ ,ordFor (u :: A.InputItem)
+ ,ordFor (u :: A.InputMode)
+ ,ordFor (u :: A.LiteralRepr)
+ ,ordFor (u :: A.OutputItem)
+ ,ordFor (u :: A.Option)
+ ,ordFor (u :: A.Process)
+ ,ordFor (u :: A.Replicator)
+ ,ordFor (u :: A.Specification)
+ ,ordFor (u :: A.SpecType)
+ ,ordFor (u :: A.Structured)
+ ,ordFor (u :: A.Subscript)
+ ,ordFor (u :: A.Type)
+ ,ordFor (u :: A.Variable)
+ ,ordFor (u :: A.Variant)
+ ]
+ where
+   u = undefined
+
+joinLines :: [String] -> String
+joinLines xs = concat [x ++ "\n" | x <- xs]
+
+main :: IO ()
+main = putStr $ joinLines $ genHeader ++ items

Makefile.am

@@ -24,6 +24,10 @@ GenTagAST$(EXEEXT): $(GenTagAST_SOURCES)
 	@MKDIR_P@ obj
 	ghc $(GHC_OPTS) -o GenTagAST$(EXEEXT) -main-is GenTagAST --make GenTagAST -odir obj -hidir obj
 
+GenOrdAST$(EXEEXT): $(GenOrdAST_SOURCES)
+	@MKDIR_P@ obj
+	ghc $(GHC_OPTS) -o GenOrdAST$(EXEEXT) -main-is GenOrdAST --make GenOrdAST -odir obj -hidir obj
+
 TOCK_CFLAGS = @gnu89_inline@ -O2 -g -Wall `kroc --cflags` `kroc --ccincpath`
 
 TOCK_CXXFLAGS = -O2 -g -Wall -ggdb3 -I.
@@ -71,7 +75,10 @@ endif
 common/TagAST.hs: GenTagAST$(EXEEXT)
 	./GenTagAST$(EXEEXT) > common/TagAST.hs
 
-BUILT_SOURCES = frontends/LexOccam.hs frontends/LexRain.hs CompilerCommands.hs common/TagAST.hs
+common/OrdAST.hs: GenOrdAST$(EXEEXT)
+	./GenOrdAST$(EXEEXT) > common/OrdAST.hs
+
+BUILT_SOURCES = frontends/LexOccam.hs frontends/LexRain.hs CompilerCommands.hs common/TagAST.hs common/OrdAST.hs
 CLEANFILES = $(BUILT_SOURCES)
 
 #One entry per line makes it easier to read and easier to modify, even if it is longer
@@ -96,6 +103,7 @@ tock_SOURCES_hs += common/FlowGraph.hs
 tock_SOURCES_hs += common/FlowAlgorithms.hs
 tock_SOURCES_hs += common/Intrinsics.hs
 tock_SOURCES_hs += common/Metadata.hs
+tock_SOURCES_hs += common/OrdAST.hs
 tock_SOURCES_hs += common/Pass.hs
 tock_SOURCES_hs += common/PassList.hs
 tock_SOURCES_hs += common/Pattern.hs
@@ -136,10 +144,11 @@ tocktest_SOURCES += frontends/RainTypesTest.hs
 tocktest_SOURCES += transformations/PassTest.hs
 
 GenTagAST_SOURCES = GenTagAST.hs
+GenOrdAST_SOURCES = GenOrdAST.hs
 
 #The programs to actually build:	
 bin_PROGRAMS = tock
-noinst_PROGRAMS = tocktest GenTagAST
+noinst_PROGRAMS = tocktest GenTagAST GenOrdAST
 
 
 clean-local:

common/AST.hs

@@ -18,6 +18,9 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 
 -- | Data types for occam abstract syntax.
 -- This is intended to be imported qualified as A.
+--
+-- All types with only no-argument constructors may (and should) derive Ord
+-- automatically, but for all other types the Ord instance is in the OrdAST module.
 module AST where
 
 {-! global : Haskell2Xml !-}