710be039cb
Previously they had a list of the types they needed to generate instances for. This patch adds some helper code that can be used to list all the AST.* types in the AST automatically. The result is that we should be able to add new types to the AST without needing to change the generator code. This also means that GenOrdAST is now generating *all* the instances of Ord for the AST; previously the trivial ones were derived by the compiler.
90 lines
3.6 KiB
Haskell
90 lines
3.6 KiB
Haskell
{-
|
|
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 Metadata
|
|
import PregenUtils
|
|
import Utils
|
|
|
|
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) => String -> a -> [String]
|
|
ordFor' typeName x = process $ map processConstr $ dataTypeConstrs $ dataTypeOf x
|
|
where
|
|
process :: [(String, String, String, [String])] -> [String]
|
|
process [] = []
|
|
process items =
|
|
["instance Ord (" ++ typeName ++ ") 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 w | DataBox w <- astTypes]
|
|
where
|
|
ordFor x = ordFor' (show $ typeOf x) x
|
|
|
|
main :: IO ()
|
|
main = putStr $ unlines $ genHeader ++ items
|