Cleanup in Setup.hs; include custom-setup:setup-depends in cabal file.

This commit is contained in:
John J. Camilleri
2018-07-05 12:23:02 +02:00
parent 992af4ab97
commit 0ef7fb8b0f
2 changed files with 46 additions and 32 deletions

View File

@@ -2,20 +2,16 @@ import Distribution.Simple(defaultMainWithHooks,UserHooks(..),simpleUserHooks)
import Distribution.Simple.LocalBuildInfo(LocalBuildInfo(..),absoluteInstallDirs,datadir) import Distribution.Simple.LocalBuildInfo(LocalBuildInfo(..),absoluteInstallDirs,datadir)
import Distribution.Simple.BuildPaths(exeExtension) import Distribution.Simple.BuildPaths(exeExtension)
import Distribution.Simple.Utils(intercalate) import Distribution.Simple.Utils(intercalate)
import Distribution.Simple.Setup(BuildFlags(..),Flag(..),InstallFlags(..),CopyDest(..),CopyFlags(..)) import Distribution.Simple.Setup(BuildFlags(..),Flag(..),InstallFlags(..),CopyDest(..),CopyFlags(..),SDistFlags(..))
import Distribution.PackageDescription(PackageDescription(..),emptyHookedBuildInfo) import Distribution.PackageDescription(PackageDescription(..),HookedBuildInfo(..),emptyHookedBuildInfo)
import Control.Monad(unless,when) import Control.Monad(unless)
import Data.List(isPrefixOf,intersect) import Data.List(isPrefixOf,intersect)
import qualified Control.Exception as E
import System.Process(readProcess) import System.Process(readProcess)
import System.FilePath((</>),(<.>)) import System.FilePath((</>),(<.>))
import System.Directory(createDirectoryIfMissing,copyFile,getDirectoryContents) import System.Directory(createDirectoryIfMissing,copyFile,getDirectoryContents,listDirectory)
import WebSetup import WebSetup
tryIOE :: IO a -> IO (Either E.IOException a)
tryIOE = E.try
main :: IO () main :: IO ()
main = defaultMainWithHooks simpleUserHooks{ preBuild = gfPreBuild main = defaultMainWithHooks simpleUserHooks{ preBuild = gfPreBuild
, postBuild = gfPostBuild , postBuild = gfPostBuild
@@ -34,8 +30,7 @@ main = defaultMainWithHooks simpleUserHooks{ preBuild = gfPreBuild
return h return h
gfPostBuild args flags pkg lbi = gfPostBuild args flags pkg lbi =
do --writeFile "running" "" do buildRGL args flags (flags,pkg,lbi)
buildRGL args flags (flags,pkg,lbi)
-- let gf = default_gf lbi -- let gf = default_gf lbi
-- buildWeb gf (pkg,lbi) -- buildWeb gf (pkg,lbi)
@@ -69,13 +64,14 @@ bf (i,_,_) = i
--pd (_,i,_) = i --pd (_,i,_) = i
lbi (_,_,i) = i lbi (_,_,i) = i
rglCommands :: [RGLCommand]
rglCommands = rglCommands =
[ RGLCommand "prelude" True $ \mode args bi -> do [ RGLCommand "prelude" True $ \mode args bi -> do
putStrLn $ "Compiling [prelude]" putStrLn $ "Compiling [prelude]"
let prelude_src_dir = rgl_src_dir </> "prelude" let prelude_src_dir = rgl_src_dir </> "prelude"
prelude_dst_dir = rgl_dst_dir (lbi bi) </> "prelude" prelude_dst_dir = rgl_dst_dir (lbi bi) </> "prelude"
createDirectoryIfMissing True prelude_dst_dir createDirectoryIfMissing True prelude_dst_dir
files <- list_files prelude_src_dir files <- listDirectory prelude_src_dir
run_gfc bi (["-s", "--gfo-dir="++prelude_dst_dir] ++ [prelude_src_dir </> file | file <- files]) run_gfc bi (["-s", "--gfo-dir="++prelude_dst_dir] ++ [prelude_src_dir </> file | file <- files])
, RGLCommand "all" True $ gfcp [l,s,c,t,sc] , RGLCommand "all" True $ gfcp [l,s,c,t,sc]
@@ -126,6 +122,7 @@ rglCommands =
-------------------------------------------------------- --------------------------------------------------------
checkRGLArgs :: [String] -> IO HookedBuildInfo
checkRGLArgs args = do checkRGLArgs args = do
let args' = filter (\arg -> not (arg `elem` all_modes || let args' = filter (\arg -> not (arg `elem` all_modes ||
rgl_prefix `isPrefixOf` arg || rgl_prefix `isPrefixOf` arg ||
@@ -134,17 +131,20 @@ checkRGLArgs args = do
putStrLn $ "Unrecognised flags: " ++ intercalate ", " args' putStrLn $ "Unrecognised flags: " ++ intercalate ", " args'
return emptyHookedBuildInfo return emptyHookedBuildInfo
buildRGL :: [String] -> BuildFlags -> Info -> IO ()
buildRGL args flags bi = do buildRGL args flags bi = do
let cmds = getRGLCommands args let cmds = getRGLCommands args
let modes = getOptMode args let modes = getOptMode args
mapM_ (\cmd -> cmdAction cmd modes args bi) cmds mapM_ (\cmd -> cmdAction cmd modes args bi) cmds
installRGL :: [String] -> InstallFlags -> (PackageDescription, LocalBuildInfo) -> IO ()
installRGL args flags bi = do installRGL args flags bi = do
let modes = getOptMode args let modes = getOptMode args
let inst_gf_lib_dir = datadir (uncurry absoluteInstallDirs bi NoCopyDest) </> "lib" let inst_gf_lib_dir = datadir (uncurry absoluteInstallDirs bi NoCopyDest) </> "lib"
copyAll "prelude" (rgl_dst_dir (snd bi) </> "prelude") (inst_gf_lib_dir </> "prelude") copyAll "prelude" (rgl_dst_dir (snd bi) </> "prelude") (inst_gf_lib_dir </> "prelude")
sequence_ [copyAll (show mode) (getRGLBuildDir (snd bi) mode) (inst_gf_lib_dir </> getRGLBuildSubDir mode)|mode<-modes] sequence_ [copyAll (show mode) (getRGLBuildDir (snd bi) mode) (inst_gf_lib_dir </> getRGLBuildSubDir mode)|mode<-modes]
copyRGL :: [String] -> CopyFlags -> (PackageDescription, LocalBuildInfo) -> IO ()
copyRGL args flags bi = do copyRGL args flags bi = do
let modes = getOptMode args let modes = getOptMode args
dest = case copyDest flags of dest = case copyDest flags of
@@ -154,11 +154,14 @@ copyRGL args flags bi = do
copyAll "prelude" (rgl_dst_dir (snd bi) </> "prelude") (inst_gf_lib_dir </> "prelude") copyAll "prelude" (rgl_dst_dir (snd bi) </> "prelude") (inst_gf_lib_dir </> "prelude")
sequence_ [copyAll (show mode) (getRGLBuildDir (snd bi) mode) (inst_gf_lib_dir </> getRGLBuildSubDir mode)|mode<-modes] sequence_ [copyAll (show mode) (getRGLBuildDir (snd bi) mode) (inst_gf_lib_dir </> getRGLBuildSubDir mode)|mode<-modes]
copyAll :: String -> FilePath -> FilePath -> IO ()
copyAll s from to = do copyAll s from to = do
putStrLn $ "Installing [" ++ s ++ "] " ++ to putStrLn $ "Installing [" ++ s ++ "] " ++ to
createDirectoryIfMissing True to createDirectoryIfMissing True to
mapM_ (\file -> copyFile (from </> file) (to </> file)) =<< list_files from mapM_ (\file -> copyFile (from </> file) (to </> file)) =<< listDirectory from
{- {-
sdistRGL :: PackageDescription -> Maybe LocalBuildInfo -> UserHooks -> SDistFlags -> IO ()
sdistRGL pkg mb_lbi hooks flags = do sdistRGL pkg mb_lbi hooks flags = do
paths <- getRGLFiles rgl_src_dir [] paths <- getRGLFiles rgl_src_dir []
let pkg' = pkg{dataFiles=paths} let pkg' = pkg{dataFiles=paths}
@@ -180,15 +183,17 @@ sdistRGL pkg mb_lbi hooks flags = do
-- | Cabal doesn't know how to correctly create the source distribution, so -- | Cabal doesn't know how to correctly create the source distribution, so
-- we print an error message with the correct instructions when someone tries -- we print an error message with the correct instructions when someone tries
-- `cabal sdist`. -- `cabal sdist`.
sdistError :: PackageDescription -> Maybe LocalBuildInfo -> UserHooks -> SDistFlags -> IO ()
sdistError _ _ _ _ = fail "Error: Use `make sdist` to create the source distribution file" sdistError _ _ _ _ = fail "Error: Use `make sdist` to create the source distribution file"
rgl_src_dir = "lib" </> "src" rgl_src_dir = "lib" </> "src"
rgl_dst_dir lbi = buildDir lbi </> "rgl" rgl_dst_dir lbi = buildDir lbi </> "rgl"
-- the languages have long directory names and short ISO codes (3 letters) -- the languages have long directory names and short ISO codes (3 letters)
-- we also give the decodings for postprocessing linearizations, as long as grammars -- we also give the decodings for postprocessing linearizations, as long as grammars
-- don't support all flags needed; they are used in tests -- don't support all flags needed; they are used in tests
langsCoding :: [((String, String), String)]
langsCoding = [ langsCoding = [
(("afrikaans","Afr"),""), (("afrikaans","Afr"),""),
(("amharic", "Amh"),""), (("amharic", "Amh"),""),
@@ -233,6 +238,7 @@ langsCoding = [
(("urdu", "Urd"),"") (("urdu", "Urd"),"")
] ]
langs :: [(String, String)]
langs = map fst langsCoding langs = map fst langsCoding
-- default set of languages to compile -- default set of languages to compile
@@ -242,7 +248,7 @@ langs = map fst langsCoding
langsLang = langs -- `except` ["Amh","Ara","Lat","Tur"] langsLang = langs -- `except` ["Amh","Ara","Lat","Tur"]
--langsLang = langs `only` ["Fin"] --test --langsLang = langs `only` ["Fin"] --test
-- languagues that have notpresent marked -- languages that have notpresent marked
langsPresent = langsLang `except` ["Afr","Chi","Eus","Gre","Heb","Ice","Jpn","Mlt","Mon","Nep","Pes","Snd","Tha","Thb","Est"] langsPresent = langsLang `except` ["Afr","Chi","Eus","Gre","Heb","Ice","Jpn","Mlt","Mon","Nep","Pes","Snd","Tha","Thb","Est"]
-- languages for which to compile Try -- languages for which to compile Try
@@ -265,8 +271,11 @@ langsPGF = langsLang `except` ["Ara","Hin","Ron","Tha"]
-- languages for which Compatibility exists (to be extended) -- languages for which Compatibility exists (to be extended)
langsCompat = langsLang `only` ["Cat","Eng","Fin","Fre","Ita","Lav","Spa","Swe"] langsCompat = langsLang `only` ["Cat","Eng","Fin","Fre","Ita","Lav","Spa","Swe"]
gfc :: Info -> [Mode] -> [Char] -> [[Char]] -> IO ()
gfc bi modes summary files = gfc bi modes summary files =
parallel_ [gfcn bi mode summary files | mode<-modes] parallel_ [gfcn bi mode summary files | mode<-modes]
gfcn :: Info -> Mode -> [Char] -> [[Char]] -> IO ()
gfcn bi mode summary files = do gfcn bi mode summary files = do
let dir = getRGLBuildDir (lbi bi) mode let dir = getRGLBuildDir (lbi bi) mode
preproc = case mode of preproc = case mode of
@@ -276,6 +285,7 @@ gfcn bi mode summary files = do
putStrLn $ "Compiling [" ++ show mode ++ "] " ++ summary putStrLn $ "Compiling [" ++ show mode ++ "] " ++ summary
run_gfc bi (["-s", "-no-pmcfg", preproc, "--gfo-dir="++dir] ++ files) run_gfc bi (["-s", "-no-pmcfg", preproc, "--gfo-dir="++dir] ++ files)
gf :: Info -> String -> [String] -> IO ()
gf bi comm files = do gf bi comm files = do
putStrLn $ "Reading " ++ unwords files putStrLn $ "Reading " ++ unwords files
let gf = default_gf (lbi bi) let gf = default_gf (lbi bi)
@@ -284,8 +294,8 @@ gf bi comm files = do
out <- readProcess gf ("-s":files) comm out <- readProcess gf ("-s":files) comm
putStrLn out putStrLn out
demos abstr ls = "gr -number=100 | l -treebank " ++ unlexer abstr ls ++ demos :: String -> [(String, String)] -> String
" | ps -to_html | wf -file=resdemo.html" demos abstr ls = "gr -number=100 | l -treebank " ++ unlexer abstr ls ++ " | ps -to_html | wf -file=resdemo.html"
lang (lla,la) = rgl_src_dir </> lla </> ("All" ++ la ++ ".gf") lang (lla,la) = rgl_src_dir </> lla </> ("All" ++ la ++ ".gf")
compat (lla,la) = rgl_src_dir </> lla </> ("Compatibility" ++ la ++ ".gf") compat (lla,la) = rgl_src_dir </> lla </> ("Compatibility" ++ la ++ ".gf")
@@ -297,9 +307,13 @@ syntax (lla,la) = rgl_src_dir </> "api" </> ("Syntax" ++ la ++ ".gf")
symbolic (lla,la) = rgl_src_dir </> "api" </> ("Symbolic" ++ la ++ ".gf") symbolic (lla,la) = rgl_src_dir </> "api" </> ("Symbolic" ++ la ++ ".gf")
parse (lla,la) = rgl_src_dir </> "parse" </> ("Parse" ++ la ++ ".gf") parse (lla,la) = rgl_src_dir </> "parse" </> ("Parse" ++ la ++ ".gf")
except :: (Eq b) => [(a, b)] -> [b] -> [(a, b)]
except ls es = filter (flip notElem es . snd) ls except ls es = filter (flip notElem es . snd) ls
only ls es = filter (flip elem es . snd) ls
only :: (Eq b) => [(a, b)] -> [b] -> [(a, b)]
only ls es = filter (flip elem es . snd) ls
getOptMode :: [String] -> [Mode]
getOptMode args = getOptMode args =
if null explicit_modes if null explicit_modes
then default_modes then default_modes
@@ -312,6 +326,7 @@ getOptMode args =
have mode = mode `elem` args have mode = mode `elem` args
-- list of languages overriding the definitions above -- list of languages overriding the definitions above
getOptLangs :: [(String, String)] -> [String] -> [(String, String)]
getOptLangs defaultLangs args = getOptLangs defaultLangs args =
case [ls | arg <- args, case [ls | arg <- args,
let (f,ls) = splitAt (length langs_prefix) arg, let (f,ls) = splitAt (length langs_prefix) arg,
@@ -328,6 +343,7 @@ getOptLangs defaultLangs args =
then findLangs langs [l]++ls then findLangs langs [l]++ls
else ls else ls
getRGLBuildSubDir :: Mode -> String
getRGLBuildSubDir mode = getRGLBuildSubDir mode =
case mode of case mode of
AllTenses -> "alltenses" AllTenses -> "alltenses"
@@ -337,6 +353,7 @@ getRGLBuildSubDir mode =
getRGLBuildDir :: LocalBuildInfo -> Mode -> FilePath getRGLBuildDir :: LocalBuildInfo -> Mode -> FilePath
getRGLBuildDir lbi mode = rgl_dst_dir lbi </> getRGLBuildSubDir mode getRGLBuildDir lbi mode = rgl_dst_dir lbi </> getRGLBuildSubDir mode
getRGLCommands :: [String] -> [RGLCommand]
getRGLCommands args = getRGLCommands args =
let cmds0 = [cmd | arg <- args, let cmds0 = [cmd | arg <- args,
let (prefix,name) = splitAt (length rgl_prefix) arg, let (prefix,name) = splitAt (length rgl_prefix) arg,
@@ -350,6 +367,7 @@ getRGLCommands args =
langs_prefix = "langs=" langs_prefix = "langs="
rgl_prefix = "rgl-" rgl_prefix = "rgl-"
unlexer :: String -> [(String, String)] -> String
unlexer abstr ls = unlexer abstr ls =
"-unlexer=\\\"" ++ unwords "-unlexer=\\\"" ++ unwords
[abstr ++ la ++ "=" ++ unl | [abstr ++ la ++ "=" ++ unl |
@@ -366,28 +384,16 @@ run_gfc bi args =
gf = default_gf (lbi bi) gf = default_gf (lbi bi)
execute gf args' execute gf args'
-- | Get path to locally-built gf
default_gf :: LocalBuildInfo -> FilePath default_gf :: LocalBuildInfo -> FilePath
default_gf lbi = buildDir lbi </> exeName' </> exeNameReal default_gf lbi = buildDir lbi </> exeName' </> exeNameReal
where where
exeName' = "gf" exeName' = "gf"
exeNameReal = exeName' <.> exeExtension exeNameReal = exeName' <.> exeExtension
{- --old solution, could pick the wrong executable if there is more than one
exeName' = (exeName . head . executables) pkg
exeNameReal = exeName' <.> (if null $ takeExtension exeName' then exeExtension else "")
-}
-- | Only update the file if contents has changed
updateFile path new =
do old <- tryIOE $ readFile path
when (Right new/=old) $ seq (either (const 0) length old) $
writeFile path new
-- | List files, excluding "." and ".."
list_files path = filter ((/=".").take 1) `fmap` getDirectoryContents path
-- | For parallel RGL module compilation -- | For parallel RGL module compilation
-- Unfortunately, this has no effect unless Setup.hs is compiled with -threaded -- Unfortunately, this has no effect unless Setup.hs is compiled with -threaded
parallel_ :: (Foldable t, Monad m) => t (m a) -> m ()
parallel_ ms = sequence_ ms {- parallel_ ms = sequence_ ms {-
do c <- newChan do c <- newChan
ts <- sequence [ forkIO (m >> writeChan c ()) | m <- ms] ts <- sequence [ forkIO (m >> writeChan c ()) | m <- ms]

View File

@@ -1,7 +1,7 @@
name: gf name: gf
version: 3.9-git version: 3.9-git
cabal-version: >= 1.20 cabal-version: >= 1.24
build-type: Custom build-type: Custom
license: OtherLicense license: OtherLicense
license-file: LICENSE license-file: LICENSE
@@ -39,6 +39,14 @@ data-files:
www/translator/*.css www/translator/*.css
www/translator/*.js www/translator/*.js
custom-setup
setup-depends:
base,
Cabal >=1.4.0.0,
directory >=1.2.5.0,
filepath,
process >=1.0.1.1
source-repository head source-repository head
type: git type: git
location: https://github.com/GrammaticalFramework/GF.git location: https://github.com/GrammaticalFramework/GF.git