From 058a3488d93e49c2f6dadea6d94255159f7660f1 Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Fri, 9 May 2008 15:46:18 +0000 Subject: [PATCH] Generate instances of a Navigable class. This isn't immediately useful, but I plan to build on it. --- Makefile.am | 30 ++++++++++++------ pregen/GenNavAST.hs | 74 +++++++++++++++++++++++++++++++++++++++++++ pregen/PregenUtils.hs | 18 +++++++++-- 3 files changed, 109 insertions(+), 13 deletions(-) create mode 100644 pregen/GenNavAST.hs diff --git a/Makefile.am b/Makefile.am index 294115c..8c8efba 100644 --- a/Makefile.am +++ b/Makefile.am @@ -38,14 +38,18 @@ tocktest$(EXEEXT): $(BUILT_SOURCES) $(tocktest_SOURCES) $(config_sources) @MKDIR_P@ obj ghc $(GHC_OPTS) -o tocktest$(EXEEXT) -main-is TestMain --make TestMain -odir obj -hidir obj -GenTagAST$(EXEEXT): $(GenTagAST_SOURCES) +GenNavAST$(EXEEXT): $(GenNavAST_SOURCES) @MKDIR_P@ obj - ghc $(GHC_OPTS) -o GenTagAST$(EXEEXT) -main-is GenTagAST --make GenTagAST -odir obj -hidir obj + ghc $(GHC_OPTS) -o GenNavAST$(EXEEXT) -main-is GenNavAST --make GenNavAST -odir obj -hidir obj GenOrdAST$(EXEEXT): $(GenOrdAST_SOURCES) @MKDIR_P@ obj ghc $(GHC_OPTS) -o GenOrdAST$(EXEEXT) -main-is GenOrdAST --make GenOrdAST -odir obj -hidir obj +GenTagAST$(EXEEXT): $(GenTagAST_SOURCES) + @MKDIR_P@ obj + ghc $(GHC_OPTS) -o GenTagAST$(EXEEXT) -main-is GenTagAST --make GenTagAST -odir obj -hidir obj + # Both these results are near-identical. The -g flag to alex tells it to generate # a lexer optimised for GHC. The other part of the rule inserts the # -fno-warn-tabs flag under GHC >= 6.8, but doesn't add anything under previous @@ -71,21 +75,25 @@ else mv frontends/LexRain.temphs frontends/LexRain.hs endif -data/TagAST.hs: GenTagAST$(EXEEXT) - ./GenTagAST$(EXEEXT) > data/TagAST.hs +config/Paths.hs: config/Paths.hs.in + @sed -e 's,@@pkgincludedir@@,$(pkgincludedir),g' \ + config/Paths.hs.in >config/Paths.hs + +data/NavAST.hs: GenNavAST$(EXEEXT) + ./GenNavAST$(EXEEXT) > data/NavAST.hs data/OrdAST.hs: GenOrdAST$(EXEEXT) ./GenOrdAST$(EXEEXT) > data/OrdAST.hs -config/Paths.hs: config/Paths.hs.in - @sed -e 's,@@pkgincludedir@@,$(pkgincludedir),g' \ - config/Paths.hs.in >config/Paths.hs +data/TagAST.hs: GenTagAST$(EXEEXT) + ./GenTagAST$(EXEEXT) > data/TagAST.hs config_sources = config/CompilerCommands.hs config_sources += config/Paths.hs config_sources += config/TypeSizes.hs -BUILT_SOURCES = data/OrdAST.hs +BUILT_SOURCES = data/NavAST.hs +BUILT_SOURCES += data/OrdAST.hs BUILT_SOURCES += data/TagAST.hs BUILT_SOURCES += frontends/LexOccam.hs BUILT_SOURCES += frontends/LexRain.hs @@ -122,6 +130,7 @@ tock_SOURCES_hs += common/Utils.hs tock_SOURCES_hs += data/AST.hs tock_SOURCES_hs += data/CompState.hs tock_SOURCES_hs += data/Metadata.hs +tock_SOURCES_hs += data/NavAST.hs tock_SOURCES_hs += data/OrdAST.hs tock_SOURCES_hs += data/TagAST.hs tock_SOURCES_hs += flow/FlowGraph.hs @@ -171,12 +180,13 @@ tocktest_SOURCES += transformations/PassTest.hs pregen_sources = data/AST.hs pregen_sources += pregen/PregenUtils.hs -GenTagAST_SOURCES = pregen/GenTagAST.hs $(pregen_sources) +GenNavAST_SOURCES = pregen/GenNavAST.hs $(pregen_sources) GenOrdAST_SOURCES = pregen/GenOrdAST.hs $(pregen_sources) +GenTagAST_SOURCES = pregen/GenTagAST.hs $(pregen_sources) #The programs to actually build: bin_PROGRAMS = tock -noinst_PROGRAMS = tocktest GenTagAST GenOrdAST +noinst_PROGRAMS = tocktest GenNavAST GenOrdAST GenTagAST TESTS = tocktest pkginclude_HEADERS = support/tock_support.h diff --git a/pregen/GenNavAST.hs b/pregen/GenNavAST.hs new file mode 100644 index 0000000..6607b0c --- /dev/null +++ b/pregen/GenNavAST.hs @@ -0,0 +1,74 @@ +{- +Tock: a compiler for parallel languages +Copyright (C) 2008 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 . +-} + +-- | Utilities for metaprogramming. +module GenNavAST where + +import Data.Generics +import qualified Data.Set as Set + +import PregenUtils +import Utils + +header :: [String] +header + = [ "{-# OPTIONS_GHC -Werror -fwarn-overlapping-patterns -fwarn-unused-matches -fwarn-unused-binds -fwarn-incomplete-patterns #-}" + , "-- | Instances that allow the AST to be navigated efficiently." + , "-- NOTE: This file is auto-generated by the GenNavAST program, " + , "-- and should not be edited directly." + , "" + , "module NavAST where" + , "" + , "import qualified AST" + , "import qualified Metadata" + , "" + , "data Navigation = Hit | Through | Miss" + , "" + , "class Navigable f t where" + , " navigate :: f -> t -> Navigation" + , "" + ] + +instancesFrom :: Data t => t -> [String] +instancesFrom w + = concat [inst c | DataBox c <- justBoxes $ astTypeMap] + where + wName = show $ typeOf w + wKey = typeKey w + + containedKeys = Set.fromList [typeKey c + | DataBox c <- justBoxes $ findTypesIn w] + + inst c + = [ "instance Navigable (" ++ wName ++ ") (" ++ cName ++ ") where" + , " navigate _ _ = " ++ result + , "" + ] + where + cName = show $ typeOf c + cKey = typeKey c + result + | wKey == cKey = "Hit" + | cKey `Set.member` containedKeys = "Through" + | otherwise = "Miss" + +main :: IO () +main = putStr $ unlines $ header ++ + concat [instancesFrom w + | DataBox w <- justBoxes $ astTypeMap] + diff --git a/pregen/PregenUtils.hs b/pregen/PregenUtils.hs index cfb22ce..2ec946b 100644 --- a/pregen/PregenUtils.hs +++ b/pregen/PregenUtils.hs @@ -18,7 +18,13 @@ with this program. If not, see . -- | Utilities for metaprogramming. module PregenUtils - ( astTypes + ( TypeMap + , astTypeMap + , astTypes + , filterModule + , findTypesIn + , justBoxes + , typeKey ) where import Control.Monad.State @@ -34,6 +40,9 @@ import Utils type TypeMap = Map Int (String, DataBox) type TypeMapM = State TypeMap +typeKey :: Typeable t => t -> Int +typeKey x = unsafePerformIO $ typeRepKey $ typeOf x + -- | Given a starting value, find all the types that could possibly be inside -- it. findTypesIn :: Data t => t -> TypeMap @@ -68,7 +77,10 @@ justBoxes = map snd . sortBy cmp . Map.elems where cmp (l, _) (r, _) = compare l r +-- | 'TypeMap' for all the types contained in the AST. +astTypeMap :: TypeMap +astTypeMap = findTypesIn (undefined :: A.AST) + -- | Witnesses for all the types defined in the 'AST' module. astTypes :: [DataBox] -astTypes = justBoxes $ filterModule "AST" $ findTypesIn (undefined :: A.AST) - +astTypes = justBoxes $ filterModule "AST" $ astTypeMap