126 lines
4.8 KiB
Haskell
126 lines
4.8 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 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) => 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 (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)
|
|
--TODO define a new function for doing a parameterised Ord
|
|
,ordFor' "(AST.Structured AST.Process)" (u :: A.Structured A.Process)
|
|
,ordFor' "(AST.Structured AST.Choice)" (u :: A.Structured A.Choice)
|
|
,ordFor' "(AST.Structured AST.Option)" (u :: A.Structured A.Option)
|
|
,ordFor' "(AST.Structured AST.Alternative)" (u :: A.Structured A.Alternative)
|
|
,ordFor' "(AST.Structured AST.Variant)" (u :: A.Structured A.Variant)
|
|
,ordFor' "(AST.Structured AST.ExpressionList)" (u :: A.Structured A.ExpressionList)
|
|
,ordFor' "(AST.Structured ())" (u :: A.Structured ())
|
|
,ordFor (u :: A.Subscript)
|
|
,ordFor (u :: A.Type)
|
|
,ordFor (u :: A.Variable)
|
|
,ordFor (u :: A.Variant)
|
|
]
|
|
where
|
|
ordFor x = ordFor' (dataTypeName $ dataTypeOf x) x
|
|
|
|
u = undefined
|
|
|
|
joinLines :: [String] -> String
|
|
joinLines xs = concat [x ++ "\n" | x <- xs]
|
|
|
|
main :: IO ()
|
|
main = putStr $ joinLines $ genHeader ++ items
|