137 lines
4.9 KiB
Haskell
137 lines
4.9 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 = joinWith " -> " $ 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
|