forked from GitHub/gf-core
[GF Split] Post-split updates
This commit is contained in:
John J. Camilleri
428
Setup.hs
428
Setup.hs
@@ -1,401 +1,67 @@
|
||||
import Distribution.Simple(defaultMainWithHooks,UserHooks(..),simpleUserHooks)
|
||||
import Distribution.Simple.LocalBuildInfo(LocalBuildInfo(..),absoluteInstallDirs,datadir)
|
||||
import Distribution.Simple.BuildPaths(exeExtension)
|
||||
import Distribution.Simple.Utils(intercalate)
|
||||
import Distribution.Simple.Setup(BuildFlags(..),Flag(..),InstallFlags(..),CopyDest(..),CopyFlags(..),SDistFlags(..))
|
||||
import Distribution.PackageDescription(PackageDescription(..),HookedBuildInfo(..),emptyHookedBuildInfo)
|
||||
import Control.Monad(unless,when)
|
||||
import Data.List(isPrefixOf,intersect)
|
||||
import System.Process(readProcess)
|
||||
import System.FilePath((</>),(<.>))
|
||||
import System.Directory(createDirectoryIfMissing,copyFile,getDirectoryContents)
|
||||
import System.Exit(die)
|
||||
import Distribution.PackageDescription(PackageDescription(..),emptyHookedBuildInfo)
|
||||
|
||||
import WebSetup
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMainWithHooks simpleUserHooks{ preBuild = gfPreBuild
|
||||
, postBuild = gfPostBuild
|
||||
, preInst = gfPreInst
|
||||
, postInst = gfPostInst
|
||||
, preCopy = const . checkRGLArgs
|
||||
, postCopy = gfPostCopy
|
||||
, sDistHook = sdistError
|
||||
}
|
||||
where
|
||||
gfPreBuild args = gfPre args . buildDistPref
|
||||
gfPreInst args = gfPre args . installDistPref
|
||||
|
||||
gfPre args distFlag =
|
||||
do h <- checkRGLArgs args
|
||||
return h
|
||||
|
||||
gfPostBuild args flags pkg lbi =
|
||||
do buildRGL args flags (flags,pkg,lbi)
|
||||
-- let gf = default_gf lbi
|
||||
-- buildWeb gf (pkg,lbi)
|
||||
|
||||
gfPostInst args flags pkg lbi =
|
||||
do installRGL args flags (pkg,lbi)
|
||||
installWeb (pkg,lbi)
|
||||
|
||||
gfPostCopy args flags pkg lbi =
|
||||
do copyRGL args flags (pkg,lbi)
|
||||
copyWeb flags (pkg,lbi)
|
||||
|
||||
--------------------------------------------------------
|
||||
-- Commands for building the Resource Grammar Library
|
||||
--------------------------------------------------------
|
||||
|
||||
data Mode = AllTenses | Present deriving Show
|
||||
all_modes = ["alltenses","present"]
|
||||
default_modes = [AllTenses,Present]
|
||||
|
||||
data RGLCommand
|
||||
= RGLCommand
|
||||
{ cmdName :: String
|
||||
, cmdIsDef :: Bool
|
||||
, cmdAction :: [Mode] -> [String] -> Info -> IO ()
|
||||
}
|
||||
|
||||
type Info = (BuildFlags,PackageDescription,LocalBuildInfo)
|
||||
bf (i,_,_) = i
|
||||
--pd (_,i,_) = i
|
||||
lbi (_,_,i) = i
|
||||
|
||||
rglCommands :: [RGLCommand]
|
||||
rglCommands =
|
||||
[ RGLCommand "prelude" True $ \mode args bi -> do
|
||||
putStrLn $ "Compiling [prelude]"
|
||||
let prelude_src_dir = rgl_src_dir </> "prelude"
|
||||
prelude_dst_dir = rgl_dst_dir (lbi bi) </> "prelude"
|
||||
createDirectoryIfMissing True prelude_dst_dir
|
||||
files <- getDirectoryContents prelude_src_dir
|
||||
run_gfc bi (["-s", "--gfo-dir="++prelude_dst_dir] ++ [prelude_src_dir </> file | file <- files, file /= "." && file /= ".."])
|
||||
|
||||
, RGLCommand "all" True $ gfcp [l,s,c,t,sc]
|
||||
, RGLCommand "lang" False $ gfcp [l,s]
|
||||
, RGLCommand "api" False $ gfcp [t,sc]
|
||||
, RGLCommand "compat" False $ gfcp [c]
|
||||
, RGLCommand "web" True $ \ _ _ bi -> buildWeb (default_gf (lbi bi)) bi
|
||||
|
||||
, RGLCommand "pgf" False $ \modes args bi ->
|
||||
parallel_ [
|
||||
do let dir = getRGLBuildDir (lbi bi) mode
|
||||
createDirectoryIfMissing True dir
|
||||
sequence_ [run_gfc bi ["-s","-make","-name=Lang"++la,
|
||||
dir ++ "/Lang" ++ la ++ ".gfo"]
|
||||
| (_,la) <- optl langsPGF args]
|
||||
run_gfc bi (["-s","-make","-name=Lang"]++
|
||||
["Lang" ++ la ++ ".pgf"|(_,la)<-optl langsPGF args])
|
||||
| mode <- modes]
|
||||
, RGLCommand "demo" False $ \modes args bi -> do
|
||||
let ls = optl langsDemo args
|
||||
gf bi (demos "Demo" ls) ["demo/Demo" ++ la ++ ".gf" | (_,la) <- ls]
|
||||
return ()
|
||||
, RGLCommand "parse" False $ \modes args bi ->
|
||||
gfc bi modes (summary parse) (map parse (optl langsParse args))
|
||||
, RGLCommand "none" False $ \modes args bi ->
|
||||
return ()
|
||||
]
|
||||
where
|
||||
gfcp cs modes args bi = parallel_ [gfcp' bi mode args cs|mode<-modes]
|
||||
|
||||
gfcp' bi mode args cs = gfcn bi mode (unwords ss) (concat fss)
|
||||
where (ss,fss) = unzip [(summary f,map f as)|c<-cs,let (f,as)=c mode args]
|
||||
|
||||
summary f = f ("*","*")
|
||||
|
||||
l mode args = (lang,optml mode langsLang args)
|
||||
s mode args = (symbol,optml mode langsAPI args)
|
||||
c mode args = (compat,optl langsCompat args)
|
||||
t mode args = (try,optml mode langsAPI args)
|
||||
sc mode args = (symbolic,optml mode langsSymbolic args)
|
||||
|
||||
optl = optml AllTenses
|
||||
optml mode ls args = getOptLangs (shrink ls) args
|
||||
where
|
||||
shrink = case mode of
|
||||
Present -> intersect langsPresent
|
||||
_ -> id
|
||||
|
||||
--------------------------------------------------------
|
||||
|
||||
checkRGLArgs :: [String] -> IO HookedBuildInfo
|
||||
checkRGLArgs args = do
|
||||
let args' = filter (\arg -> not (arg `elem` all_modes ||
|
||||
rgl_prefix `isPrefixOf` arg ||
|
||||
langs_prefix `isPrefixOf` arg)) args
|
||||
unless (null args') $
|
||||
putStrLn $ "Unrecognised flags: " ++ intercalate ", " args'
|
||||
return emptyHookedBuildInfo
|
||||
|
||||
buildRGL :: [String] -> BuildFlags -> Info -> IO ()
|
||||
buildRGL args flags bi = do
|
||||
let cmds = getRGLCommands args
|
||||
let modes = getOptMode args
|
||||
mapM_ (\cmd -> cmdAction cmd modes args bi) cmds
|
||||
|
||||
installRGL :: [String] -> InstallFlags -> (PackageDescription, LocalBuildInfo) -> IO ()
|
||||
installRGL args flags bi = do
|
||||
let modes = getOptMode args
|
||||
let inst_gf_lib_dir = datadir (uncurry absoluteInstallDirs bi NoCopyDest) </> "lib"
|
||||
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]
|
||||
|
||||
copyRGL :: [String] -> CopyFlags -> (PackageDescription, LocalBuildInfo) -> IO ()
|
||||
copyRGL args flags bi = do
|
||||
let modes = getOptMode args
|
||||
dest = case copyDest flags of
|
||||
NoFlag -> NoCopyDest
|
||||
Flag d -> d
|
||||
let inst_gf_lib_dir = datadir (uncurry absoluteInstallDirs bi dest) </> "lib"
|
||||
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]
|
||||
|
||||
copyAll :: String -> FilePath -> FilePath -> IO ()
|
||||
copyAll s from to = do
|
||||
putStrLn $ "Installing [" ++ s ++ "] " ++ to
|
||||
createDirectoryIfMissing True to
|
||||
mapM_ (\file -> when (file /= "." && file /= "..") $ copyFile (from </> file) (to </> file)) =<< getDirectoryContents from
|
||||
|
||||
{-
|
||||
sdistRGL :: PackageDescription -> Maybe LocalBuildInfo -> UserHooks -> SDistFlags -> IO ()
|
||||
sdistRGL pkg mb_lbi hooks flags = do
|
||||
paths <- getRGLFiles rgl_src_dir []
|
||||
let pkg' = pkg{dataFiles=paths}
|
||||
sDistHook simpleUserHooks pkg' mb_lbi hooks flags
|
||||
where
|
||||
getRGLFiles dir paths = foldM (processFile dir) paths =<< ls dir
|
||||
|
||||
processFile dir paths file = do
|
||||
let path = dir </> file
|
||||
print path
|
||||
isFile <- doesFileExist path
|
||||
if isFile
|
||||
then if takeExtension file == ".gf" || file == "LICENSE"
|
||||
then return (path : paths)
|
||||
else return paths
|
||||
else getRGLFiles path paths
|
||||
-}
|
||||
-- | Notice about RGL not built anymore
|
||||
noRGLmsg :: IO ()
|
||||
noRGLmsg = putStrLn "Notice: the RGL is not built as part of GF anymore. See https://github.com/GrammaticalFramework/gf-rgl"
|
||||
|
||||
-- | Cabal doesn't know how to correctly create the source distribution, so
|
||||
-- we print an error message with the correct instructions when someone tries
|
||||
-- `cabal sdist`.
|
||||
sdistError :: PackageDescription -> Maybe LocalBuildInfo -> UserHooks -> SDistFlags -> IO ()
|
||||
sdistError _ _ _ _ = fail "Error: Use `make sdist` to create the source distribution file"
|
||||
sdistError _ _ _ _ = fail "Use `make sdist` to create the source distribution file"
|
||||
|
||||
rgl_src_dir = "lib" </> "src"
|
||||
rgl_dst_dir lbi = buildDir lbi </> "rgl"
|
||||
|
||||
-- the languages have long directory names and short ISO codes (3 letters)
|
||||
-- we also give the decodings for postprocessing linearizations, as long as grammars
|
||||
-- don't support all flags needed; they are used in tests
|
||||
|
||||
langsCoding :: [((String, String), String)]
|
||||
langsCoding = [
|
||||
(("afrikaans","Afr"),""),
|
||||
(("amharic", "Amh"),""),
|
||||
(("arabic", "Ara"),""),
|
||||
(("basque", "Eus"),""),
|
||||
(("bulgarian","Bul"),""),
|
||||
(("catalan", "Cat"),""),
|
||||
(("chinese", "Chi"),""),
|
||||
(("danish", "Dan"),""),
|
||||
(("dutch", "Dut"),""),
|
||||
(("english", "Eng"),""),
|
||||
(("estonian", "Est"),""),
|
||||
(("finnish", "Fin"),""),
|
||||
(("french", "Fre"),""),
|
||||
(("ancient_greek","Grc"),""),
|
||||
(("greek", "Gre"),""),
|
||||
(("hebrew", "Heb"),""),
|
||||
(("hindi", "Hin"),"to_devanagari"),
|
||||
(("german", "Ger"),""),
|
||||
(("icelandic","Ice"),""),
|
||||
(("interlingua","Ina"),""),
|
||||
(("italian", "Ita"),""),
|
||||
(("japanese", "Jpn"),""),
|
||||
(("latin", "Lat"),""),
|
||||
(("latvian", "Lav"),""),
|
||||
(("maltese", "Mlt"),""),
|
||||
(("mongolian","Mon"),""),
|
||||
(("nepali", "Nep"),""),
|
||||
(("norwegian","Nor"),""),
|
||||
(("nynorsk", "Nno"),""),
|
||||
(("persian", "Pes"),""),
|
||||
(("polish", "Pol"),""),
|
||||
(("portuguese", "Por"), ""),
|
||||
(("punjabi", "Pnb"),""),
|
||||
(("romanian", "Ron"),""),
|
||||
(("russian", "Rus"),""),
|
||||
(("sindhi", "Snd"),""),
|
||||
(("spanish", "Spa"),""),
|
||||
(("swedish", "Swe"),""),
|
||||
(("thai", "Tha"),"to_thai"),
|
||||
(("turkish", "Tur"),""),
|
||||
(("urdu", "Urd"),"")
|
||||
]
|
||||
|
||||
langs :: [(String, String)]
|
||||
langs = map fst langsCoding
|
||||
|
||||
-- default set of languages to compile
|
||||
-- defaultLangs = langs `only` words "Eng Fre Ger Ita Spa Swe"
|
||||
|
||||
-- languagues for which to compile Lang
|
||||
langsLang = langs -- `except` ["Amh","Ara","Lat","Tur"]
|
||||
--langsLang = langs `only` ["Fin"] --test
|
||||
|
||||
-- languages that have notpresent marked
|
||||
langsPresent = langsLang `except` ["Afr","Chi","Eus","Gre","Heb","Ice","Jpn","Mlt","Mon","Nep","Pes","Snd","Tha","Thb","Est"]
|
||||
|
||||
-- languages for which to compile Try
|
||||
langsAPI = langsLang `except` langsIncomplete -- ["Ina","Amh","Ara"]
|
||||
|
||||
langsIncomplete = ["Amh","Ara","Grc","Heb","Ina","Lat","Tur"]
|
||||
|
||||
-- languages for which to compile Symbolic
|
||||
langsSymbolic = langsAPI `except` ["Afr","Ice","Mon","Nep"]
|
||||
|
||||
-- languages for which to run demo test
|
||||
langsDemo = langsLang `except` ["Ara","Hin","Ina","Lav","Tha"]
|
||||
|
||||
-- languages for which to compile parsing grammars
|
||||
langsParse = langs `only` ["Eng"]
|
||||
|
||||
-- languages for which langs.pgf is built
|
||||
langsPGF = langsLang `except` ["Ara","Hin","Ron","Tha"]
|
||||
|
||||
-- languages for which Compatibility exists (to be extended)
|
||||
langsCompat = langsLang `only` ["Cat","Eng","Fin","Fre","Ita","Lav","Spa","Swe"]
|
||||
|
||||
gfc :: Info -> [Mode] -> [Char] -> [[Char]] -> IO ()
|
||||
gfc bi modes summary files =
|
||||
parallel_ [gfcn bi mode summary files | mode<-modes]
|
||||
|
||||
gfcn :: Info -> Mode -> [Char] -> [[Char]] -> IO ()
|
||||
gfcn bi mode summary files = do
|
||||
let dir = getRGLBuildDir (lbi bi) mode
|
||||
preproc = case mode of
|
||||
AllTenses -> ""
|
||||
Present -> "-preproc="++({-rgl_src_dir </>-} "mkPresent")
|
||||
createDirectoryIfMissing True dir
|
||||
putStrLn $ "Compiling [" ++ show mode ++ "] " ++ summary
|
||||
run_gfc bi (["-s", "-no-pmcfg", preproc, "--gfo-dir="++dir] ++ files)
|
||||
|
||||
gf :: Info -> String -> [String] -> IO ()
|
||||
gf bi comm files = do
|
||||
putStrLn $ "Reading " ++ unwords files
|
||||
let gf = default_gf (lbi bi)
|
||||
putStrLn ("executing: " ++ comm ++ "\n" ++
|
||||
"in " ++ gf)
|
||||
out <- readProcess gf ("-s":files) comm
|
||||
putStrLn out
|
||||
|
||||
demos :: String -> [(String, String)] -> String
|
||||
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")
|
||||
compat (lla,la) = rgl_src_dir </> lla </> ("Compatibility" ++ la ++ ".gf")
|
||||
symbol (lla,la) = rgl_src_dir </> lla </> ("Symbol" ++ la ++ ".gf")
|
||||
|
||||
try (lla,la) = rgl_src_dir </> "api" </> ("Try" ++ la ++ ".gf")
|
||||
syntax (lla,la) = rgl_src_dir </> "api" </> ("Syntax" ++ la ++ ".gf")
|
||||
|
||||
symbolic (lla,la) = rgl_src_dir </> "api" </> ("Symbolic" ++ 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
|
||||
|
||||
only :: (Eq b) => [(a, b)] -> [b] -> [(a, b)]
|
||||
only ls es = filter (flip elem es . snd) ls
|
||||
|
||||
getOptMode :: [String] -> [Mode]
|
||||
getOptMode args =
|
||||
if null explicit_modes
|
||||
then default_modes
|
||||
else explicit_modes
|
||||
main :: IO ()
|
||||
main = defaultMainWithHooks simpleUserHooks
|
||||
{ preBuild = gfPreBuild
|
||||
, postBuild = gfPostBuild
|
||||
, preInst = gfPreInst
|
||||
, postInst = gfPostInst
|
||||
, postCopy = gfPostCopy
|
||||
, sDistHook = sdistError
|
||||
}
|
||||
where
|
||||
explicit_modes =
|
||||
[Present|have "present"]++
|
||||
[AllTenses|have "alltenses"]
|
||||
gfPreBuild args = gfPre args . buildDistPref
|
||||
gfPreInst args = gfPre args . installDistPref
|
||||
|
||||
have mode = mode `elem` args
|
||||
gfPre args distFlag = do
|
||||
return emptyHookedBuildInfo
|
||||
|
||||
-- list of languages overriding the definitions above
|
||||
getOptLangs :: [(String, String)] -> [String] -> [(String, String)]
|
||||
getOptLangs defaultLangs args =
|
||||
case [ls | arg <- args,
|
||||
let (f,ls) = splitAt (length langs_prefix) arg,
|
||||
f==langs_prefix] of
|
||||
('+':ls):_ -> foldr addLang defaultLangs (seps ls)
|
||||
('-':ls):_ -> foldr removeLang defaultLangs (seps ls)
|
||||
ls:_ -> findLangs langs (seps ls)
|
||||
_ -> defaultLangs
|
||||
where
|
||||
seps = words . map (\c -> if c==',' then ' ' else c)
|
||||
findLangs langs ls = [lang | lang@(_,la) <- langs, la `elem` ls]
|
||||
removeLang l ls = [lang | lang@(_,la) <- ls, la/=l]
|
||||
addLang l ls = if null (findLangs ls [l])
|
||||
then findLangs langs [l]++ls
|
||||
else ls
|
||||
gfPostBuild args flags pkg lbi = do
|
||||
noRGLmsg
|
||||
|
||||
getRGLBuildSubDir :: Mode -> String
|
||||
getRGLBuildSubDir mode =
|
||||
case mode of
|
||||
AllTenses -> "alltenses"
|
||||
Present -> "present"
|
||||
gfPostInst args flags pkg lbi = do
|
||||
noRGLmsg
|
||||
saveInstallPath args flags (pkg,lbi)
|
||||
installWeb (pkg,lbi)
|
||||
|
||||
gfPostCopy args flags pkg lbi = do
|
||||
noRGLmsg
|
||||
saveCopyPath args flags (pkg,lbi)
|
||||
copyWeb flags (pkg,lbi)
|
||||
|
||||
getRGLBuildDir :: LocalBuildInfo -> Mode -> FilePath
|
||||
getRGLBuildDir lbi mode = rgl_dst_dir lbi </> getRGLBuildSubDir mode
|
||||
saveInstallPath :: [String] -> InstallFlags -> (PackageDescription, LocalBuildInfo) -> IO ()
|
||||
saveInstallPath args flags bi = do
|
||||
let
|
||||
dest = NoCopyDest
|
||||
dir = datadir (uncurry absoluteInstallDirs bi dest)
|
||||
writeFile dataDirFile dir
|
||||
|
||||
getRGLCommands :: [String] -> [RGLCommand]
|
||||
getRGLCommands args =
|
||||
let cmds0 = [cmd | arg <- args,
|
||||
let (prefix,name) = splitAt (length rgl_prefix) arg,
|
||||
prefix == rgl_prefix,
|
||||
cmd <- rglCommands,
|
||||
cmdName cmd == name]
|
||||
in if null cmds0
|
||||
then [cmd | cmd <- rglCommands, cmdIsDef cmd]
|
||||
else cmds0
|
||||
saveCopyPath :: [String] -> CopyFlags -> (PackageDescription, LocalBuildInfo) -> IO ()
|
||||
saveCopyPath args flags bi = do
|
||||
let
|
||||
dest = case copyDest flags of
|
||||
NoFlag -> NoCopyDest
|
||||
Flag d -> d
|
||||
dir = datadir (uncurry absoluteInstallDirs bi dest)
|
||||
writeFile dataDirFile dir
|
||||
|
||||
langs_prefix = "langs="
|
||||
rgl_prefix = "rgl-"
|
||||
|
||||
unlexer :: String -> [(String, String)] -> String
|
||||
unlexer abstr ls =
|
||||
"-unlexer=\\\"" ++ unwords
|
||||
[abstr ++ la ++ "=" ++ unl |
|
||||
lla@(_,la) <- ls, let unl = unlex lla, not (null unl)] ++
|
||||
"\\\""
|
||||
where
|
||||
unlex lla = maybe "" id $ lookup lla langsCoding
|
||||
|
||||
-- | Runs the gf executable in compile mode with the given arguments.
|
||||
run_gfc :: Info -> [String] -> IO ()
|
||||
run_gfc bi args =
|
||||
do let args' = numJobs (bf bi)++["-batch","-gf-lib-path="++rgl_src_dir]
|
||||
++ filter (not . null) args
|
||||
gf = default_gf (lbi bi)
|
||||
ok <- execute gf args'
|
||||
if ok then return () else die "Stopping"
|
||||
|
||||
-- | Get path to locally-built gf
|
||||
default_gf :: LocalBuildInfo -> FilePath
|
||||
default_gf lbi = buildDir lbi </> exeName' </> exeNameReal
|
||||
where
|
||||
exeName' = "gf"
|
||||
exeNameReal = exeName' <.> exeExtension
|
||||
|
||||
-- | For parallel RGL module compilation
|
||||
-- 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 {-
|
||||
do c <- newChan
|
||||
ts <- sequence [ forkIO (m >> writeChan c ()) | m <- ms]
|
||||
sequence_ [readChan c | _ <- ts]
|
||||
--}
|
||||
-- | Name of file where installation's data directory is recording
|
||||
-- This is a last-resort way in which the seprate RGL build script
|
||||
-- can determine where to put the compiled RGL files
|
||||
dataDirFile :: String
|
||||
dataDirFile = "DATA_DIR"
|
||||
|
||||
Reference in New Issue
Block a user