90 lines
3.5 KiB
Haskell
90 lines
3.5 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 [" ++ joinWith "," 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
|