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:
parent
2d00b1e5c5
commit
0e2a944788
19
GenOrdAST.hs
19
GenOrdAST.hs
|
@ -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
|
||||
|
||||
|
|
45
GenTagAST.hs
45
GenTagAST.hs
|
@ -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)]
|
||||
|
|
|
@ -1,4 +1,5 @@
|
|||
GHC_OPTS = \
|
||||
-prof -auto-all \
|
||||
-fglasgow-exts \
|
||||
-fwarn-deprecations \
|
||||
-fwarn-duplicate-exports \
|
||||
|
|
Loading…
Reference in New Issue
Block a user