diff options
Diffstat (limited to 'Setup.hs')
| -rw-r--r-- | Setup.hs | 440 |
1 files changed, 53 insertions, 387 deletions
@@ -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" - -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" +sdistError _ _ _ _ = fail "Use `make sdist` to create the source distribution file" --- 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 - where - explicit_modes = - [Present|have "present"]++ - [AllTenses|have "alltenses"] - - have mode = mode `elem` args - --- 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 - -getRGLBuildSubDir :: Mode -> String -getRGLBuildSubDir mode = - case mode of - AllTenses -> "alltenses" - Present -> "present" - - -getRGLBuildDir :: LocalBuildInfo -> Mode -> FilePath -getRGLBuildDir lbi mode = rgl_dst_dir lbi </> getRGLBuildSubDir mode - -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 - -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 +main :: IO () +main = defaultMainWithHooks simpleUserHooks + { preBuild = gfPreBuild + , postBuild = gfPostBuild + , preInst = gfPreInst + , postInst = gfPostInst + , postCopy = gfPostCopy + , sDistHook = sdistError + } where - exeName' = "gf" - exeNameReal = exeName' <.> exeExtension + gfPreBuild args = gfPre args . buildDistPref + gfPreInst args = gfPre args . installDistPref --- | 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] ---} + gfPre args distFlag = do + return emptyHookedBuildInfo + + gfPostBuild args flags pkg lbi = do + noRGLmsg + + 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) + +saveInstallPath :: [String] -> InstallFlags -> (PackageDescription, LocalBuildInfo) -> IO () +saveInstallPath args flags bi = do + let + dest = NoCopyDest + dir = datadir (uncurry absoluteInstallDirs bi dest) + writeFile dataDirFile dir + +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 + +-- | 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" |