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.
137 lines
5.0 KiB
Haskell
137 lines
5.0 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 TagAST module. Template Haskell was a bit too heavyweight
|
|
-- for this. Uses Data.Generics to pick out all the constructors for the
|
|
-- given types, work out their "arity" and write out the TagAST module
|
|
-- (to stdout).
|
|
module GenTagAST where
|
|
|
|
import Data.Char
|
|
import Data.Generics
|
|
import Data.List (intersperse)
|
|
|
|
import PregenUtils
|
|
import Utils
|
|
|
|
genHeader :: [String]
|
|
genHeader = [
|
|
"-- | Contains lots of helper functions for matching AST elements."
|
|
,"-- For most AST.Blah items, there is an mBlah and mBlah' definition here."
|
|
,"-- mBlah is without the Meta tag pattern (DontCare is used), mBlah' is with a Meta tag pattern."
|
|
,"--"
|
|
,"-- NOTE: This file is auto-generated by the GenTagAST program, and should not be edited directly."
|
|
,"module TagAST where"
|
|
,"import Data.Generics"
|
|
,""
|
|
,"import qualified AST"
|
|
,"import qualified Metadata"
|
|
,"import Pattern"
|
|
,"import TreeUtils"
|
|
-- Could probably auto-generate these, too:
|
|
,"type F0 = Pattern"
|
|
,"type F1 = (Data a0) => a0 -> Pattern"
|
|
,"type F2 = (Data a0, Data a1) => a0 -> a1 -> Pattern"
|
|
,"type F3 = (Data a0, Data a1, Data a2) => a0 -> a1 -> a2 -> Pattern"
|
|
,"type F4 = (Data a0, Data a1, Data a2, Data a3) => a0 -> a1 -> a2 -> a3 -> Pattern"
|
|
,"type F5 = (Data a0, Data a1, Data a2, Data a3, Data a4) => a0 -> a1 -> a2 -> a3 -> a4 -> Pattern"
|
|
,"type F6 = (Data a0, Data a1, Data a2, Data a3, Data a4, Data a5) => a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> Pattern"
|
|
,"type F0' a = Pattern"
|
|
,"type F1' a0 = a0 -> Pattern"
|
|
,"type F2' a1 = (Data a0) => a0 -> a1 -> Pattern"
|
|
,"type F3' a2 = (Data a0, Data a1) => a0 -> a1 -> a2 -> Pattern"
|
|
,"type F4' a3 = (Data a0, Data a1, Data a2) => a0 -> a1 -> a2 -> a3 -> Pattern"
|
|
,"type F5' a4 = (Data a0, Data a1, Data a2, Data a3) => a0 -> a1 -> a2 -> a3 -> a4 -> Pattern"
|
|
,"type F6' a5 = (Data a0, Data a1, Data a2, Data a3, Data a4) => a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> Pattern"
|
|
,""
|
|
]
|
|
|
|
genItem :: (Int, String) -> [String]
|
|
genItem (num, name)
|
|
= [mname ++ "' :: F" ++ n
|
|
,mname ++ "' = tag" ++ n ++ " AST." ++ name
|
|
,mname ++ " :: F" ++ show (num - 1)
|
|
,mname ++ " = " ++ mname ++ "' DontCare"]
|
|
where
|
|
n = show num
|
|
mname = "m" ++ name
|
|
|
|
genItem' :: String -> String -> (Int, String, [String]) -> [String]
|
|
genItem' suffix typeName (num, name, paramTypes)
|
|
= [mname ++ "' :: F" ++ n ++ typeSuffix
|
|
,mname ++ "' = tag" ++ n ++ " (AST." ++ name ++ " :: " ++ params ++ ")"
|
|
,mname ++ " :: F" ++ show (num - 1) ++ typeSuffix
|
|
,mname ++ " = " ++ mname ++ "' DontCare"]
|
|
where
|
|
typeSuffix = ""
|
|
|
|
params = concat $ intersperse " -> " $ paramTypes ++ [typeName]
|
|
|
|
n = show num
|
|
mname = "m" ++ name ++ suffix
|
|
|
|
consFor :: forall a. Data a => a -> [(Int, String)]
|
|
consFor x = map consFor' (dataTypeConstrs $ dataTypeOf x)
|
|
where
|
|
-- The way I work out how many arguments a constructor takes is crazy, but
|
|
-- I can't see a better way given the Data.Generics API
|
|
consFor' :: Constr -> (Int, String)
|
|
consFor' con = (glength (fromConstr con :: a), showConstr con)
|
|
|
|
consParamsFor :: forall a. Data a => a -> [(Int, String, [String])]
|
|
consParamsFor x = map consParamsFor' (dataTypeConstrs $ dataTypeOf x)
|
|
where
|
|
-- The way I work out how many arguments a constructor takes is crazy, but
|
|
-- I can't see a better way given the Data.Generics API
|
|
consParamsFor' :: Constr -> (Int, String, [String])
|
|
consParamsFor' con = (length cons, showConstr con, cons)
|
|
where
|
|
cons :: [String]
|
|
cons = gmapQ (show . typeOf) (fromConstr con :: a)
|
|
|
|
items :: [String]
|
|
items = concat [gen w | DataBox w <- astTypes]
|
|
where
|
|
gen w
|
|
= case typeRepArgs rep of
|
|
-- A parameterised type (e.g. Structured Process).
|
|
[arg] -> genParam arg w
|
|
-- A normal type (e.g. Process).
|
|
_ -> genNormal w
|
|
where
|
|
rep = typeOf w
|
|
|
|
genParam arg w
|
|
= concatMap (genItem' prefix (show $ typeOf w)) $ consParamsFor w
|
|
where
|
|
argS = show arg
|
|
prefix
|
|
| argS == "()" = "AST"
|
|
| otherwise = filter isUpper (drop (1 + index '.' argS) argS)
|
|
|
|
index c s = length (takeWhile (/= c) s)
|
|
|
|
genNormal w
|
|
= concatMap genItem (filterInvalid $ consFor w)
|
|
|
|
filterInvalid :: [(Int, a)] -> [(Int, a)]
|
|
filterInvalid = filter (\(n,_) -> n > 0)
|
|
|
|
main :: IO ()
|
|
main = putStr $ unlines $ genHeader ++ items
|