Make GenOrdAST and GenTagAST use Typeable.

This simplifies the code quite a bit, since Typeable knows about
parameters to types; you don't have to do magic to handle
Structured Thingy any more.
This commit is contained in:
Adam Sampson 2008-05-08 15:37:56 +00:00
parent 2d00b1e5c5
commit 0e2a944788
3 changed files with 26 additions and 39 deletions

View File

@ -53,7 +53,7 @@ ordFor' typeName x = process $ map processConstr $ dataTypeConstrs $ dataTypeOf
process :: [(String, String, String, [String])] -> [String]
process [] = []
process items =
["instance Ord " ++ typeName ++ " where"]
["instance Ord (" ++ typeName ++ ") where"]
++ concat [ [ " compare (" ++ name ++ headL ++ ") (" ++ name ++ headR ++ ") = " ++
--Shortcut:
if null comparisons then "EQ" else
@ -100,21 +100,20 @@ items = concat
,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.Structured A.Process)
,ordFor (u :: A.Structured A.Choice)
,ordFor (u :: A.Structured A.Option)
,ordFor (u :: A.Structured A.Alternative)
,ordFor (u :: A.Structured A.Variant)
,ordFor (u :: A.Structured A.ExpressionList)
,ordFor (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
ordFor x = ordFor' (show $ typeOf x) x
u = undefined

View File

@ -30,7 +30,7 @@ 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."
,"-- 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."
@ -38,7 +38,6 @@ genHeader = [
,"import Data.Generics"
,""
,"import qualified AST"
,"import qualified AST as A"
,"import qualified Metadata"
,"import Pattern"
,"import TreeUtils"
@ -63,7 +62,7 @@ genHeader = [
genItem :: (Int, String) -> [String]
genItem (num, name)
= [mname ++ "' :: F" ++ n
,mname ++ "' = tag" ++ n ++ " A." ++ name
,mname ++ "' = tag" ++ n ++ " AST." ++ name
,mname ++ " :: F" ++ show (num - 1)
,mname ++ " = " ++ mname ++ "' DontCare"]
where
@ -73,19 +72,14 @@ genItem (num, 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 ++ "' = tag" ++ n ++ " (AST." ++ 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]
params = concat $ intersperse " -> " $ paramTypes ++ [typeName]
n = show num
mname = "m" ++ name ++ suffix
@ -106,16 +100,7 @@ consParamsFor x = map consParamsFor' (dataTypeConstrs $ dataTypeOf x)
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
cons = gmapQ (show . typeOf) (fromConstr con :: a)
items :: [(Int, String)]
items = concat
@ -146,14 +131,16 @@ items = concat
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 ())
[consP "P" (undefined :: A.Structured A.Process)
,consP "O" (undefined :: A.Structured A.Option)
,consP "C" (undefined :: A.Structured A.Choice)
,consP "V" (undefined :: A.Structured A.Variant)
,consP "A" (undefined :: A.Structured A.Alternative)
,consP "EL" (undefined :: A.Structured A.ExpressionList)
,consP "AST" (undefined :: A.Structured ())
]
where
consP prefix w = concatMap (genItem' prefix (show $ typeOf w)) $ consParamsFor w
filterInvalid :: [(Int, a)] -> [(Int, a)]

View File

@ -1,4 +1,5 @@
GHC_OPTS = \
-prof -auto-all \
-fglasgow-exts \
-fwarn-deprecations \
-fwarn-duplicate-exports \