From 263dfd6fd34ed16ac5520fc40e9507d6901c6907 Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Sun, 14 Dec 2008 15:37:05 +0000 Subject: [PATCH] Allowed the different instances for the Polyplate classes to be written out to separate files (to help GHC's memory usage down a bit) --- Makefile.am | 6 +++- .../Data/Generics/Polyplate/GenInstances.hs | 32 +++++++++++++------ pregen/GenNavAST.hs | 21 ++++++++++-- 3 files changed, 45 insertions(+), 14 deletions(-) diff --git a/Makefile.am b/Makefile.am index 9b545ed..106a83b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -111,7 +111,10 @@ config/Paths.hs: config/Paths.hs.in | sed -e 's,@@tocklibdir@@,$(TOCKLIBDIR),g' >config/Paths.hs data/NavAST.hs: GenNavAST$(EXEEXT) - ./GenNavAST$(EXEEXT) > data/NavAST.hs + ./GenNavAST$(EXEEXT) data/NavAST.hs data/NavASTSpine.hs + +data/NavASTSpine.hs: GenNavAST$(EXEEXT) + ./GenNavAST$(EXEEXT) data/NavAST.hs data/NavASTSpine.hs data/OrdAST.hs: GenOrdAST$(EXEEXT) ./GenOrdAST$(EXEEXT) > data/OrdAST.hs @@ -124,6 +127,7 @@ config_sources += config/Paths.hs config_sources += config/TypeSizes.hs BUILT_SOURCES = data/NavAST.hs +BUILT_SOURCES += data/NavASTSpine.hs BUILT_SOURCES += data/OrdAST.hs BUILT_SOURCES += data/TagAST.hs BUILT_SOURCES += frontends/LexOccam.hs diff --git a/polyplate/Data/Generics/Polyplate/GenInstances.hs b/polyplate/Data/Generics/Polyplate/GenInstances.hs index 448a3fc..4a589d3 100644 --- a/polyplate/Data/Generics/Polyplate/GenInstances.hs +++ b/polyplate/Data/Generics/Polyplate/GenInstances.hs @@ -19,7 +19,7 @@ with this program. If not, see . module Data.Generics.Polyplate.GenInstances (GenOverlappedOption(..), GenClassOption(..), GenInstance, genInstance, genMapInstance, genSetInstance, genInstances, - writeInstances, writeInstancesTo) where + writeInstances, writeInstancesTo, writeInstancesToSep) where import Control.Monad.State import Data.Char @@ -597,28 +597,40 @@ spineInstancesFrom genOverlapped genClass boxes w -- | Generates all the given instances (eliminating any duplicates) -- with the given options. -genInstances :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> IO [String] +genInstances :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> + IO ([String], [String]) genInstances op1 op2 insts = do typeMap <- flip execStateT Map.empty (sequence [g | GenInstance g <- insts]) - liftM concat $ sequence [liftM2 (++) - (instancesFrom op1 op2 (justBoxes typeMap) w) - (spineInstancesFrom op1 op2 (justBoxes typeMap) w) + let (inst, spineInst) = unzip [ + (instancesFrom op1 op2 (justBoxes typeMap) w + ,spineInstancesFrom op1 op2 (justBoxes typeMap) w) | DataBox w <- map witness $ justBoxes typeMap] - + inst' <- sequence inst + spineInst' <- sequence spineInst + return (concat inst', concat spineInst') -- | Generates the instances according to the options and writes it to stdout with -- the given header. writeInstances :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> [String] -> IO () writeInstances op1 op2 inst header - = do instLines <- genInstances op1 op2 inst - putStr (unlines (header ++ instLines)) + = do (instLines, spineInstLines) <- genInstances op1 op2 inst + putStr (unlines (header ++ instLines ++ spineInstLines)) + +-- | Generates the instances according to the options and writes it to stdout with +-- the given header. +writeInstancesToSep :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> ([String], + [String]) -> (FilePath, FilePath) -> IO () +writeInstancesToSep op1 op2 inst (header1, header2) (fileName1, fileName2) + = do (instLines, spineInstLines) <- genInstances op1 op2 inst + writeFile fileName1 (unlines (header1 ++ instLines)) + writeFile fileName2 (unlines (header2 ++ spineInstLines)) -- | Generates the instances according to the options and writes it to a file with -- the given header. writeInstancesTo :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> [String] -> FilePath -> IO () writeInstancesTo op1 op2 inst header fileName - = do instLines <- genInstances op1 op2 inst - writeFile fileName (unlines (header ++ instLines)) + = do (instLines, spineInstLines) <- genInstances op1 op2 inst + writeFile fileName (unlines (header ++ instLines ++ spineInstLines)) --{{{ Various SYB-based functions that we don't export, for discovering contained types: diff --git a/pregen/GenNavAST.hs b/pregen/GenNavAST.hs index 448c83e..98fe1cc 100644 --- a/pregen/GenNavAST.hs +++ b/pregen/GenNavAST.hs @@ -19,6 +19,9 @@ with this program. If not, see . -- | Utilities for metaprogramming. module GenNavAST where +import Data.List +import System.Environment + import Data.Generics.Polyplate.GenInstances import qualified AST @@ -148,8 +151,9 @@ instancesFrom w = " transformM (_, rest) ops b v = transformM rest ops b v" main :: IO () -main - = writeInstances GenWithoutOverlapped GenClassPerType +main = do + [instFileName, spineInstFileName] <- getArgs + writeInstancesToSep GenWithoutOverlapped GenClassPerType [ genInstance (undefined :: AST.AST) , genInstance (undefined :: CompState.CompState) -- All the maps that are in CompState: @@ -163,9 +167,19 @@ main , genSetInstance (undefined :: String) , genSetInstance (undefined :: AST.Name) ] + (header False (findModuleName instFileName), header True (findModuleName spineInstFileName)) + (instFileName, spineInstFileName) + where + findModuleName moduleFileName + | not (".hs" `isSuffixOf` moduleFileName) + = error "file name does not end in .hs" + | otherwise + = (reverse . takeWhile (/= '/') . drop 3 . reverse) $ moduleFileName + + header useTree moduleName = ["{-# OPTIONS_GHC -Werror -fwarn-overlapping-patterns -fwarn-unused-matches -fwarn-unused-binds -fwarn-incomplete-patterns #-}" ,"-- | This module is auto-generated by Polyplate. DO NOT EDIT." - ,"module NavAST where" + ,"module " ++ moduleName ++ " where" ,"" ,"import Data.Generics.Polyplate" ,"" @@ -173,6 +187,7 @@ main ,"import qualified Data.Map as Map" ,"import Data.Set (Set)" ,"import qualified Data.Set as Set" + ,if useTree then "import Data.Tree" else "" ,"" ,"import qualified AST" ,"import qualified CompState"