acd57d74de
This patch is actually an amalgam of multiple (already large) patches. Those patches conflicted (parameterised Structured vs. changes to usage checking and FlowGraph) and encountered a nasty bug in darcs 1 involving exponential time (see http://wiki.darcs.net/DarcsWiki/ConflictsFAQ for more details). Reasoning that half an hour (of 100% CPU use) was too long to apply patches, I opted to re-record the parameterised Structured changes as this new large patch. Here are the commit messages originally used for the patches (which, as mentioned, were already large patches): A gigantic patch switching all the non-test modules over to using parameterised A.Structured Changed the FlowGraph module again to handle any sort of Structured you want to pass to it (mainly for testing) A further gigantic patch changing all the tests to work with the new parameterised Structured Fixed a nasty bug involving functions being named incorrectly inside transformInputCase Added a hand-written instance of Data for Structured that allows us to use ext1M properly Fixed a few warnings in the code
167 lines
6.3 KiB
Haskell
167 lines
6.3 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.Generics
|
|
import Data.List (intersperse)
|
|
|
|
import qualified AST as A
|
|
|
|
genHeader :: [String]
|
|
genHeader = [
|
|
"-- | Contains lots of helper functions for matching AST elements."
|
|
,"-- For most A.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 AST as A"
|
|
,"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 ++ " A." ++ 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 ++ " (A." ++ name ++ " :: " ++ params ++ ")"
|
|
,mname ++ " :: F" ++ show (num - 1) ++ typeSuffix
|
|
,mname ++ " = " ++ mname ++ "' DontCare"]
|
|
where
|
|
-- typeSuffix = "' (" ++ typeName ++ ")"
|
|
typeSuffix = ""
|
|
|
|
params = concat $ intersperse " -> " $
|
|
[case p of
|
|
"AST.Structured" -> typeName
|
|
"[AST.Structured]" -> "[" ++ typeName ++ "]"
|
|
_ -> p | p <- 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 = (length (gmapQ (const undefined) (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 showDataType (fromConstr con :: a)
|
|
|
|
-- Hack to handle various types:
|
|
showDataType :: Data b => b -> String
|
|
showDataType y = case n of
|
|
"Prelude.[]" -> "[" ++ (dataTypeName $ dataTypeOf x) ++ "]"
|
|
"Prelude.()" -> "()"
|
|
_ -> n
|
|
where
|
|
n = dataTypeName $ dataTypeOf y
|
|
|
|
items :: [(Int, String)]
|
|
items = concat
|
|
[consFor (u :: A.Actual)
|
|
,consFor (u :: A.Alternative)
|
|
,consFor (u :: A.ArrayConstr)
|
|
,consFor (u :: A.ArrayElem)
|
|
,consFor (u :: A.Choice)
|
|
,consFor (u :: A.Expression)
|
|
,consFor (u :: A.ExpressionList)
|
|
,consFor (u :: A.Formal)
|
|
,consFor (u :: A.InputItem)
|
|
,consFor (u :: A.InputMode)
|
|
,consFor (u :: A.LiteralRepr)
|
|
,consFor (u :: A.OutputItem)
|
|
,consFor (u :: A.Option)
|
|
,consFor (u :: A.Process)
|
|
,consFor (u :: A.Replicator)
|
|
,consFor (u :: A.Specification)
|
|
,consFor (u :: A.SpecType)
|
|
,consFor (u :: A.Subscript)
|
|
,consFor (u :: A.Type)
|
|
,consFor (u :: A.Variable)
|
|
,consFor (u :: A.Variant)
|
|
]
|
|
where
|
|
u = undefined
|
|
|
|
struct :: [String]
|
|
struct = concat
|
|
[concatMap (genItem' "P" "A.Structured A.Process") $ consParamsFor (undefined :: A.Structured A.Process)
|
|
,concatMap (genItem' "O" "A.Structured A.Option") $ consParamsFor (undefined :: A.Structured A.Option)
|
|
,concatMap (genItem' "C" "A.Structured A.Choice") $ consParamsFor (undefined :: A.Structured A.Choice)
|
|
,concatMap (genItem' "V" "A.Structured A.Variant") $ consParamsFor (undefined :: A.Structured A.Variant)
|
|
,concatMap (genItem' "A" "A.Structured A.Alternative") $ consParamsFor (undefined :: A.Structured A.Alternative)
|
|
,concatMap (genItem' "EL" "A.Structured A.ExpressionList") $ consParamsFor (undefined :: A.Structured A.ExpressionList)
|
|
,concatMap (genItem' "AST" "A.Structured ()") $ consParamsFor (undefined :: A.Structured ())
|
|
]
|
|
|
|
|
|
filterInvalid :: [(Int, a)] -> [(Int, a)]
|
|
filterInvalid = filter (\(n,_) -> n > 0)
|
|
|
|
joinLines :: [String] -> String
|
|
joinLines xs = concat [x ++ "\n" | x <- xs]
|
|
|
|
main :: IO ()
|
|
main = putStr $ joinLines $ genHeader ++ concatMap genItem (filterInvalid items) ++ struct
|