Add support for building/copying individual modules in Make.hs

Particularly useful for ExtraEng, large monolingual dicts, etc.

Make.hs

@@ -1,12 +1,12 @@
-import Data.List (find,intersect,isPrefixOf)
+import Data.List (find,intersect,isPrefixOf,isSuffixOf)
 import Data.Maybe (fromJust,isJust,catMaybes)
 import System.IO (hPutStrLn,stderr)
 import System.IO.Error (catchIOError)
 import System.Exit (ExitCode(..),die)
 import System.Environment (getArgs,lookupEnv)
 import System.Process (rawSystem,readProcess)
-import System.FilePath ((</>),(<.>))
+import System.FilePath ((</>),(<.>),takeFileName,addExtension,dropExtension)
-import System.Directory (createDirectoryIfMissing,copyFile,getDirectoryContents,removeDirectoryRecursive)
+import System.Directory (createDirectoryIfMissing,copyFile,getDirectoryContents,removeDirectoryRecursive,doesFileExist)
 import Control.Monad (unless,when)
 
 main :: IO ()
@@ -14,7 +14,7 @@ main = do
   aargs <- getArgs
   case aargs of
     [] -> putStrLn $ "Must specify command, one of: " ++ unwords commands
-    a:_ | a `notElem` commands -> putStrLn $ "Unknown command: " ++ a ++ " (valid commands: " ++ unwords commands ++ ")"
+    a:_ | a `notElem` commands -> putStrLn $ "Unknown command: " ++ a ++ ". Valid commands: " ++ unwords commands
     "build":args -> buildRGL args
     "copy":args -> copyRGL args
     "install":args -> buildRGL args >> copyRGL args
@@ -25,8 +25,7 @@ main = do
 -- | Build grammars into dist
 buildRGL :: [String] -> IO ()
 buildRGL args = do
-  checkArgs args
+  let cmds = getCommands args
-  let cmds = getRGLCommands args
   let modes = getOptMode args
   info <- mkInfo
   mapM_ (\cmd -> cmdAction cmd modes args info) cmds
@@ -37,8 +36,15 @@ copyRGL args = do
   let modes = getOptMode args
   info <- mkInfo
   gf_lib_dir <- maybe (die errLocation) return (infoInstallDir info)
-  copyAll "prelude" (infoBuildDir info </> "prelude") (gf_lib_dir </> "prelude")
+  let files = getOptModules args
-  sequence_ [copyAll (show mode) (getRGLBuildDir info mode) (gf_lib_dir </> getRGLBuildSubDir mode)|mode<-modes]
+  if not (null files)
+  then do
+    -- Copy single files
+    sequence_ [copyOne (flip addExtension "gfo" . dropExtension . takeFileName $ file) (getRGLBuildDir info mode) (gf_lib_dir </> getRGLBuildSubDir mode)|file<-files, mode<-modes]
+  else do
+    -- Copy everything
+    copyAll "prelude" (infoBuildDir info </> "prelude") (gf_lib_dir </> "prelude")
+    sequence_ [copyAll (show mode) (getRGLBuildDir info mode) (gf_lib_dir </> getRGLBuildSubDir mode)|mode<-modes]
 
 -- | Error message when install location cannot be determined
 errLocation :: String
@@ -49,10 +55,17 @@ errLocation = unlines $
   , " - Compile & install GF from the gf-core repository (must be in same directory as gf-rgl)"
   ]
 
+-- | Copy single file between directories
+copyOne :: String -> FilePath -> FilePath -> IO ()
+copyOne file from to = do
+  putStrLn $ "Copying [" ++ file ++ "] " ++ to
+  createDirectoryIfMissing True to
+  copyFile (from </> file) (to </> file)
+
 -- | Copy all files between directories
 copyAll :: String -> FilePath -> FilePath -> IO ()
 copyAll msg from to = do
-  putStrLn $ "Installing [" ++ msg ++ "] " ++ to
+  putStrLn $ "Copying [" ++ msg ++ "] " ++ to
   createDirectoryIfMissing True to
   mapM_ (\file -> when (file /= "." && file /= "..") $ copyFile (from </> file) (to </> file)) =<< getDirectoryContents from
 
@@ -62,54 +75,6 @@ clean = do
   info <- mkInfo
   removeDirectoryRecursive (infoBuildDir info)
 
--- | Flag for specifying languages
--- '=' can optionally be followed by '+' or '-' to alter the default languages
-lang_flag :: String
-lang_flag = "--langs="
-
--- | Flag for specifying gf location
-gf_flag :: String
-gf_flag = "--gf="
-
--- | Flag for specifying RGL install location
-destination_flag :: String
-destination_flag = "--dest="
-
--- | Check arguments are valid
-checkArgs :: [String] -> IO ()
-checkArgs args = do
-  let args' = flip filter args (\arg -> not
-        (  arg `elem` (map cmdName rglCommands)
-        || arg `elem` all_modes
-        || lang_flag `isPrefixOf` arg
-        || gf_flag `isPrefixOf` arg
-        || destination_flag `isPrefixOf` arg
-        ))
-  unless (null args') $ die $ "Unrecognised flags: " ++ unwords args'
-  return ()
-
--- | List of languages overriding the definitions below
-getOptLangs :: [LangInfo] -> [String] -> [LangInfo]
-getOptLangs defaultLangs args =
-    case [ls | arg <- args,
-               let (f,ls) = splitAt (length lang_flag) arg,
-               f==lang_flag] 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 <- langs, langCode lang `elem` ls]
-    removeLang l ls = [lang | lang <- ls, langCode lang /= l]
-    addLang l ls = if null (findLangs ls [l])
-                   then findLangs langs [l]++ls
-                   else ls
-
--- | Get flag value from list of args
-getFlag :: String -> [String] -> Maybe String
-getFlag flag args = fmap (drop (length flag)) $ find (isPrefixOf flag) args
-
 -------------------------------------------------------------------------------
 -- Paths and directories
 
@@ -122,7 +87,7 @@ data Info = Info
   { infoBuildDir :: FilePath -- ^ where to put built RGL modules (fixed)
   , infoInstallDir :: Maybe FilePath -- ^ install directory (found dynamically)
   , infoGFPath :: FilePath -- ^ path to GF
-  }
+  } deriving (Show)
 
 -- | Build info object from command line args
 mkInfo :: IO Info
@@ -178,19 +143,33 @@ data RGLCommand = RGLCommand
 -- | Possible build commands
 rglCommands :: [RGLCommand]
 rglCommands =
-  [ RGLCommand "prelude" True  $ \mode args bi -> do
+  [ RGLCommand "prelude" True  $ \modes args bi -> do
-       putStrLn $ "Compiling [prelude]"
+      putStrLn $ "Building [prelude]"
-       let prelude_src_dir = sourceDir       </> "prelude"
+      let prelude_src_dir = sourceDir       </> "prelude"
-           prelude_dst_dir = infoBuildDir bi </> "prelude"
+          prelude_dst_dir = infoBuildDir bi </> "prelude"
-       createDirectoryIfMissing True prelude_dst_dir
+      createDirectoryIfMissing True prelude_dst_dir
-       files <- getDirectoryContents prelude_src_dir
+      files <- getDirectoryContents prelude_src_dir
-       run_gfc bi (["-s", "--gfo-dir="++prelude_dst_dir] ++ [prelude_src_dir </> file | file <- files, file /= "." && file /= ".."])
+      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 "modules"  False $ \modes args bi ->  do
+      let modules = getOptModules args
+      flip mapM_ modules $ \m -> do
+        -- TODO search for modules so that folder name is not needed
+        -- TODO determine dependants, e.g. include ExtraEngAbs when specifying ExtraEng
+        let mfull = sourceDir </> m
+        ex <- doesFileExist mfull
+        if not ex
+        then die $ "Cannot find module: " ++ m
+        else flip mapM_ modes $ \mode -> do
+          let dst = getRGLBuildDir bi mode
+          putStrLn $ "Building [" ++ m ++ "] " ++ dst
+          run_gfc bi ["-s", "--gfo-dir="++dst, mfull]
+
   -- , RGLCommand "pgf"     False $ \modes args bi ->
   --    parallel_ [
   --      do let dir = getRGLBuildDir bi mode
@@ -232,6 +211,36 @@ rglCommands =
                    Present -> intersect langsPresent
                    _ -> id
 
+-- | Get commands from args
+-- Fails on command error
+getCommands :: [String] -> [RGLCommand]
+getCommands args =
+  let
+    cmdModules = head $ filter (\cmd -> cmdName cmd == "modules") rglCommands
+    cmds0 =
+      [ cmd
+      | arg <- args
+      , cmd <- rglCommands
+      , cmdName cmd == arg
+      , cmdName cmd `notElem` all_modes
+      ] ++ (if not (null (getOptModules args)) then [cmdModules] else [])
+  in if null cmds0
+       then [cmd | cmd <- rglCommands, cmdIsDef cmd]
+       else cmds0
+
+-- -- | Check arguments are valid
+-- checkArgs :: [String] -> IO ()
+-- checkArgs args = do
+--   let args' = flip filter args (\arg -> not
+--         (  arg `elem` (map cmdName rglCommands)
+--         || arg `elem` all_modes
+--         || lang_flag `isPrefixOf` arg
+--         || gf_flag `isPrefixOf` arg
+--         || destination_flag `isPrefixOf` arg
+--         ))
+--   unless (null args') $ die $ "Unrecognised flags: " ++ unwords args'
+--   return ()
+
 -- | Get mode from args (may be missing)
 getOptMode :: [String] -> [Mode]
 getOptMode args =
@@ -244,15 +253,45 @@ getOptMode args =
       [AllTenses|have "alltenses"]
     have mode = mode `elem` args
 
--- | Get RGL command from args
+-- | List of languages overriding the definitions below
-getRGLCommands :: [String] -> [RGLCommand]
+getOptLangs :: [LangInfo] -> [String] -> [LangInfo]
-getRGLCommands args =
+getOptLangs defaultLangs args =
-  let cmds0 = [cmd | arg <- args,
+    case [ls | arg <- args,
-                     cmd <- rglCommands,
+               let (f,ls) = splitAt (length lang_flag) arg,
-                     cmdName cmd == arg]
+               f==lang_flag] of
-  in if null cmds0
+      ('+':ls):_ -> foldr addLang defaultLangs (seps ls)
-       then [cmd | cmd <- rglCommands, cmdIsDef cmd]
+      ('-':ls):_ -> foldr removeLang defaultLangs (seps ls)
-       else cmds0
+      ls:_ -> findLangs langs (seps ls)
+      _    -> defaultLangs
+  where
+    seps = words . map (\c -> if c==',' then ' ' else c)
+    findLangs langs ls = [lang | lang <- langs, langCode lang `elem` ls]
+    removeLang l ls = [lang | lang <- ls, langCode lang /= l]
+    addLang l ls = if null (findLangs ls [l])
+                   then findLangs langs [l]++ls
+                   else ls
+
+-- | Get module names from arguments
+-- TODO check if they exist
+getOptModules :: [String] -> [FilePath]
+getOptModules = filter (isSuffixOf ".gf")
+
+-- | Flag for specifying languages
+-- '=' can optionally be followed by '+' or '-' to alter the default languages
+lang_flag :: String
+lang_flag = "--langs="
+
+-- | Flag for specifying gf location
+gf_flag :: String
+gf_flag = "--gf="
+
+-- | Flag for specifying RGL install location
+destination_flag :: String
+destination_flag = "--dest="
+
+-- | Get flag value from list of args
+getFlag :: String -> [String] -> Maybe String
+getFlag flag args = fmap (drop (length flag)) $ find (isPrefixOf flag) args
 
 -------------------------------------------------------------------------------
 -- Languages of the RGL
@@ -398,7 +437,7 @@ gfcn bi mode summary files = do
                   AllTenses -> ""
                   Present   -> "-preproc=mkPresent"
   createDirectoryIfMissing True dir
-  putStrLn $ "Compiling [" ++ show mode ++ "] " ++ summary
+  putStrLn $ "Building [" ++ show mode ++ "] " ++ summary
   run_gfc bi (["-s", "-no-pmcfg", preproc, "--gfo-dir="++dir] ++ files)
 
 -- | Runs the gf executable in compile mode with the given arguments

README.md

@@ -50,25 +50,26 @@ runghc Make.hs ...
 
 Where `...` is one of:
 ```
-build   [CMD] [MODE] [--langs=[+|-]LANG,LANG,...] [--gf=...]
+build   [CMDS] [MODE] [--langs=[+|-]LANG,LANG,...] [--gf=...]
-copy    [--dest=...]
+copy    [FILES] [MODE] [--dest=...]
-install [CMD] [MODE] [--langs=[+|-]LANG,LANG,...] [--gf=...] [--dest=...]
+install [CMDS] [MODE] [--langs=[+|-]LANG,LANG,...] [--gf=...] [--dest=...]
 clean
 ```
 
-- `CMD` is one of:
+- `CMDS` is one or more of:
 `prelude`,
-`all`,
+`all` (default),
 `lang`,
 `api`,
 `compat`,
 <!-- `pgf`, -->
-`parse`
+`parse`,
-(default is `all`)
+or an explicit module name (e.g. `english/ExtraEng.gf`).
 - `MODE` is one of:
 `present`,
 `alltenses`
-(default is both)
+(default is both).
+- `FILES` is a space separated list of module names (e.g. `english/ExtraEng.gf german/DictGer.gf`)
 - You can _override_ the default language list with `--langs=...`
 - You can _add_ languages to the default list with `--langs=+...`
 - You can _remove_ languages from the default list with `langs=-...`
@@ -79,7 +80,7 @@ clean
 ## Shell script: `Make.sh`
 
 This method is provided as an alternative for those who don't have Haskell installed.
-Simply run the script to build the entire RGL and install in the default location:
+Simply run the script to build the entire RGL and install in the default location.
 
 You can pass the following flags:
 - `--dest=...` to manually specify the install location
@@ -104,7 +105,7 @@ One difference is that the list of languages to be compiled is specified manuall
 On 2018-07-25, the monolithic [GF repository](https://github.com/GrammaticalFramework/GF)
 was split in two:
 
-1. [gf-core](https://github.com/GrammaticalFramework/gf-core) —  the GF compiler, shell and runtimes
+1. [gf-core](https://github.com/GrammaticalFramework/gf-core) — the GF compiler, shell and runtimes
 2. [gf-rgl](https://github.com/GrammaticalFramework/gf-rgl) — the resource grammar library
 
 The former repository is now archived and no longer updated.