Generate instances of a Navigable class.
This isn't immediately useful, but I plan to build on it.
This commit is contained in:
Adam Sampson
parent
710be039cb
commit
058a3488d9
30
Makefile.am
30
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
|
||||
|
|
|
|||
74
pregen/GenNavAST.hs
Normal file
74
pregen/GenNavAST.hs
Normal file
|
|
@ -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 <http://www.gnu.org/licenses/>.
|
||||
-}
|
||||
|
||||
-- | 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]
|
||||
|
||||
|
|
@ -18,7 +18,13 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
|
|||
|
||||
-- | 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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user