From 0e2a9447884c6ce6f3f31220d20161f80c0b83ca Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Thu, 8 May 2008 15:37:56 +0000 Subject: [PATCH] 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. --- GenOrdAST.hs | 19 +++++++++---------- GenTagAST.hs | 45 ++++++++++++++++----------------------------- Makefile.am | 1 + 3 files changed, 26 insertions(+), 39 deletions(-) diff --git a/GenOrdAST.hs b/GenOrdAST.hs index 051fd18..c58cae5 100644 --- a/GenOrdAST.hs +++ b/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 diff --git a/GenTagAST.hs b/GenTagAST.hs index 0ab4ef4..9c5e6f8 100644 --- a/GenTagAST.hs +++ b/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)] diff --git a/Makefile.am b/Makefile.am index e997b93..d811be1 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,4 +1,5 @@ GHC_OPTS = \ + -prof -auto-all \ -fglasgow-exts \ -fwarn-deprecations \ -fwarn-duplicate-exports \