[GF Split] Post-split updates

2018-07-25 20:18:48 +02:00
parent 5d058bcfc0
commit ade493515a
31 changed files with 602 additions and 406 deletions
--- a/Make.hs
+++ b/Make.hs
@@ -0,0 +1,434 @@
+import Data.List (find,intersect,isPrefixOf)
+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.Directory (createDirectoryIfMissing,copyFile,getDirectoryContents,removeDirectoryRecursive)
+import Control.Monad (unless,when)
+
+main :: IO ()
+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 ++ ")"
+    "build":args -> buildRGL args
+    "copy":args -> copyRGL args
+    "install":args -> buildRGL args >> copyRGL args
+    "clean":_ -> clean
+  where
+    commands = ["build","copy","install","clean"]
+
+-- | Build grammars into dist
+buildRGL :: [String] -> IO ()
+buildRGL args = do
+  checkArgs args
+  let cmds = getRGLCommands args
+  let modes = getOptMode args
+  info <- mkInfo
+  mapM_ (\cmd -> cmdAction cmd modes args info) cmds
+
+-- | Copy from dist to install location
+copyRGL :: [String] -> IO ()
+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")
+  sequence_ [copyAll (show mode) (getRGLBuildDir info mode) (gf_lib_dir </> getRGLBuildSubDir mode)|mode<-modes]
+
+-- | Error message when install location cannot be determined
+errLocation :: String
+errLocation = unlines $
+  [ "Unable to determine where to install the RGL. Please do one of the following:"
+  , " - Pass the " ++ destination_flag ++ "... flag to this script"
+  , " - Set the GF_LIB_PATH environment variable"
+  , " - Compile & install GF from the gf-core repository (must be in same directory as gf-rgl)"
+  ]
+
+-- | Copy all files between directories
+copyAll :: String -> FilePath -> FilePath -> IO ()
+copyAll msg from to = do
+  putStrLn $ "Installing [" ++ msg ++ "] " ++ to
+  createDirectoryIfMissing True to
+  mapM_ (\file -> when (file /= "." && file /= "..") $ copyFile (from </> file) (to </> file)) =<< getDirectoryContents from
+
+-- | Remove dist directory
+clean :: IO ()
+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
+
+-- | RGL source directory
+sourceDir :: FilePath
+sourceDir = "src"
+
+-- | Information needed in build
+data Info = Info
+  { infoBuildDir :: FilePath -- ^ where to put built RGL modules (fixed)
+  , infoInstallDir :: Maybe FilePath -- ^ install directory (found dynamically)
+  , infoGFPath :: FilePath -- ^ path to GF
+  }
+
+-- | Build info object from command line args
+mkInfo :: IO Info
+mkInfo = do
+  args <- getArgs
+
+  -- Look for install location in a few different places
+  let mflag = getFlag destination_flag args
+  mbuilt <- catchIOError (readFile "../gf-core/DATA_DIR" >>= \d -> return (Just (d </> "lib"))) (\e -> return Nothing)
+  menvar <- lookupEnv "GF_LIB_PATH"
+  let
+    inst_dir =
+      case catMaybes [mflag,menvar,mbuilt] of
+        [] -> Nothing
+        p:_ -> Just p
+
+  return $ Info
+    { infoBuildDir = "dist"
+    , infoInstallDir = inst_dir
+    , infoGFPath = maybe default_gf id (getFlag gf_flag args)
+    }
+  where
+    default_gf = "gf"
+
+getRGLBuildDir :: Info -> Mode -> FilePath
+getRGLBuildDir info mode = infoBuildDir info </> getRGLBuildSubDir mode
+
+getRGLBuildSubDir :: Mode -> String
+getRGLBuildSubDir mode =
+  case mode of
+    AllTenses -> "alltenses"
+    Present   -> "present"
+
+-------------------------------------------------------------------------------
+-- Build modes
+
+data Mode = AllTenses | Present
+  deriving (Show)
+
+all_modes :: [String]
+all_modes = ["alltenses","present"]
+
+default_modes :: [Mode]
+default_modes = [AllTenses,Present]
+
+-- | An RGL build command
+data RGLCommand = RGLCommand
+  { cmdName   :: String -- ^ name of command
+  , cmdIsDef  :: Bool   -- ^ is default?
+  , cmdAction :: [Mode] -> [String] -> Info -> IO () -- ^ action
+  }
+
+-- | Possible build commands
+rglCommands :: [RGLCommand]
+rglCommands =
+  [ RGLCommand "prelude" True  $ \mode args bi -> do
+       putStrLn $ "Compiling [prelude]"
+       let prelude_src_dir = sourceDir       </> "prelude"
+           prelude_dst_dir = infoBuildDir 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 "pgf"     False $ \modes args bi ->
+     parallel_ [
+       do let dir = getRGLBuildDir bi mode
+          createDirectoryIfMissing True dir
+          sequence_ [run_gfc bi ["-s","-make","-name=Lang"++la,
+                                       dir ++ "/Lang" ++ la ++ ".gfo"]
+                      | l <- optl langsPGF args, let la = langCode l]
+          run_gfc bi (["-s","-make","-name=Lang"]++
+                           ["Lang" ++ langCode l ++ ".pgf"|l <- optl langsPGF args])
+       | mode <- modes]
+
+  , RGLCommand "parse"   False $ \modes args bi ->
+       gfc bi modes (summary parse) (map parse (optl langsParse args))
+  ]
+  where
+    gfcp :: [Mode -> [String] -> (LangInfo -> FilePath,[LangInfo])] -> [Mode] -> [String] -> Info -> IO ()
+    gfcp cs modes args bi = parallel_ [gfcp' bi mode args cs | mode <- modes]
+
+    gfcp' :: Info -> Mode -> [String] -> [Mode -> [String] -> (LangInfo -> FilePath,[LangInfo])] -> IO ()
+    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 :: (LangInfo -> FilePath) -> FilePath
+    summary f = f (LangInfo "*" "*" Nothing Nothing)
+
+    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 :: [LangInfo] -> [String] -> [LangInfo]
+    optl = optml AllTenses
+
+    optml :: Mode -> [LangInfo] -> [String] -> [LangInfo]
+    optml mode ls args = getOptLangs (shrink ls) args
+      where
+        shrink = case mode of
+                   Present -> intersect langsPresent
+                   _ -> id
+
+-- | Get mode from args (may be missing)
+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
+
+-- | Get RGL command from args
+getRGLCommands :: [String] -> [RGLCommand]
+getRGLCommands args =
+  let cmds0 = [cmd | arg <- args,
+                     cmd <- rglCommands,
+                     cmdName cmd == arg]
+  in if null cmds0
+       then [cmd | cmd <- rglCommands, cmdIsDef cmd]
+       else cmds0
+
+-------------------------------------------------------------------------------
+-- Languages of the RGL
+
+-- | Information about a language
+data LangInfo = LangInfo
+  { langCode :: String -- ^ 3-letter ISO 639-2/B code
+  , langDir :: String -- ^ directory name
+  , langFunctor :: Maybe String -- ^ functor (not used)
+  , langUnlexer :: Maybe String -- ^ decoding for postprocessing linearizations
+  } deriving (Eq)
+
+-- | List of all languages known to RGL
+langs :: [LangInfo]
+langs =
+  [ LangInfo "Afr" "afrikaans" Nothing Nothing
+  , LangInfo "Amh" "amharic" Nothing Nothing
+  , LangInfo "Ara" "arabic" Nothing Nothing
+  , LangInfo "Eus" "basque" Nothing Nothing
+  , LangInfo "Bul" "bulgarian" Nothing Nothing
+  , LangInfo "Cat" "catalan" (Just "Romance") Nothing
+  , LangInfo "Chi" "chinese" Nothing Nothing
+  , LangInfo "Dan" "danish" (Just "Scand") Nothing
+  , LangInfo "Dut" "dutch" Nothing Nothing
+  , LangInfo "Eng" "english" Nothing Nothing
+  , LangInfo "Est" "estonian" Nothing Nothing
+  , LangInfo "Fin" "finnish" Nothing Nothing
+  , LangInfo "Fre" "french" (Just "Romance") Nothing
+  , LangInfo "Grc" "ancient_greek" Nothing Nothing
+  , LangInfo "Gre" "greek" Nothing Nothing
+  , LangInfo "Heb" "hebrew" Nothing Nothing
+  , LangInfo "Hin" "hindi" (Just "Hindustani") (Just "to_devanagari")
+  , LangInfo "Ger" "german" Nothing Nothing
+  , LangInfo "Ice" "icelandic" Nothing Nothing
+  , LangInfo "Ina" "interlingua" Nothing Nothing
+  , LangInfo "Ita" "italian" (Just "Romance") Nothing
+  , LangInfo "Jpn" "japanese" Nothing Nothing
+  , LangInfo "Lat" "latin" Nothing Nothing
+  , LangInfo "Lav" "latvian" Nothing Nothing
+  , LangInfo "Mlt" "maltese" Nothing Nothing
+  , LangInfo "Mon" "mongolian" Nothing Nothing
+  , LangInfo "Nep" "nepali" Nothing Nothing
+  , LangInfo "Nor" "norwegian" (Just "Scand") Nothing
+  , LangInfo "Nno" "nynorsk" Nothing Nothing
+  , LangInfo "Pes" "persian" Nothing Nothing
+  , LangInfo "Pol" "polish" Nothing Nothing
+  , LangInfo "Por" "portuguese" (Just "Romance") Nothing
+  , LangInfo "Pnb" "punjabi" Nothing Nothing
+  , LangInfo "Ron" "romanian" Nothing Nothing
+  , LangInfo "Rus" "russian" Nothing Nothing
+  , LangInfo "Snd" "sindhi" Nothing Nothing
+  , LangInfo "Spa" "spanish" (Just "Romance") Nothing
+  , LangInfo "Swe" "swedish" (Just "Scand") Nothing
+  , LangInfo "Tha" "thai" Nothing (Just "to_thai")
+  , LangInfo "Tur" "turkish" Nothing Nothing
+  , LangInfo "Urd" "urdu" (Just "Hindustani") Nothing
+  ]
+
+-- | Languagues for which to compile Lang
+langsLang :: [LangInfo]
+langsLang = langs
+
+-- | Languages that have notpresent marked
+langsPresent :: [LangInfo]
+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 :: [LangInfo]
+langsAPI = langsLang `except` langsIncomplete
+
+-- | Languages which compile but which are incomplete
+langsIncomplete :: [String]
+langsIncomplete = ["Amh","Ara","Grc","Heb","Ina","Lat","Tur"]
+
+-- | Languages for which to compile Symbolic
+langsSymbolic :: [LangInfo]
+langsSymbolic  = langsAPI `except` ["Afr","Ice","Mon","Nep"]
+
+-- | Languages for which to compile parsing grammars
+langsParse :: [LangInfo]
+langsParse = langs `only` ["Eng"]
+
+-- | Languages for which langs.pgf is built
+langsPGF :: [LangInfo]
+langsPGF = langsLang `except` ["Ara","Hin","Ron","Tha"]
+
+-- | Languages for which Compatibility exists (to be extended)
+langsCompat :: [LangInfo]
+langsCompat = langsLang `only` ["Cat","Eng","Fin","Fre","Ita","Lav","Spa","Swe"]
+
+-- | Exclude langs from list by code
+except :: [LangInfo] -> [String] -> [LangInfo]
+except ls es = filter (flip notElem es . langCode) ls
+
+-- | Only specified langs by code
+only ::  [LangInfo] -> [String] -> [LangInfo]
+only ls es = filter (flip elem es . langCode) ls
+
+-------------------------------------------------------------------------------
+-- Getting module paths/names
+
+lang :: LangInfo -> FilePath
+lang l = sourceDir </> langDir l </> ("All" ++ langCode l ++ ".gf")
+
+compat :: LangInfo -> FilePath
+compat l = sourceDir </> langDir l </> ("Compatibility" ++ langCode l ++ ".gf")
+
+symbol :: LangInfo -> FilePath
+symbol l = sourceDir </> langDir l </> ("Symbol" ++ langCode l ++ ".gf")
+
+try :: LangInfo -> FilePath
+try l = sourceDir </> "api" </> ("Try" ++ langCode l ++ ".gf")
+
+syntax :: LangInfo -> FilePath
+syntax l = sourceDir </> "api" </> ("Syntax" ++ langCode l ++ ".gf")
+
+symbolic :: LangInfo -> FilePath
+symbolic l = sourceDir </> "api" </> ("Symbolic" ++ langCode l ++ ".gf")
+
+parse :: LangInfo -> FilePath
+parse l = sourceDir </> "parse" </> ("Parse" ++ langCode l ++ ".gf")
+
+-- | Get unlexer flags for languages
+unlexer :: String -> [LangInfo] -> String
+unlexer abstr ls =
+  "-unlexer=\\\"" ++ unwords
+    [ abstr ++ langCode lang ++ "=" ++ fromJust unl
+    | lang <- ls
+    , let unl = langUnlexer lang
+    , isJust unl] ++ "\\\""
+
+-------------------------------------------------------------------------------
+-- Executing GF
+
+gfc :: Info -> [Mode] -> String -> [String] -> IO ()
+gfc bi modes summary files =
+  parallel_ [gfcn bi mode summary files | mode<-modes]
+
+gfcn :: Info -> Mode -> String -> [String] -> IO ()
+gfcn bi mode summary files = do
+  let dir = getRGLBuildDir bi mode
+      preproc = case mode of
+                  AllTenses -> ""
+                  Present   -> "-preproc=mkPresent"
+  createDirectoryIfMissing True dir
+  putStrLn $ "Compiling [" ++ 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
+run_gfc :: Info -> [String] -> IO ()
+run_gfc bi args = do
+  let
+    args' = ["-batch","-gf-lib-path="++sourceDir] ++ filter (not . null) args
+    gf = infoGFPath bi
+  execute gf args'
+
+-- | Run an arbitrary system command
+execute :: String -> [String] -> IO ()
+execute command args = do
+  let cmdline = command ++ " " ++ unwords (map showArg args)
+  e <- rawSystem command args
+  case e of
+    ExitSuccess   -> return ()
+    ExitFailure i -> do
+      putStrLn $ "Ran: " ++ cmdline
+      die $ command ++ " exited with exit code: " ++ show i
+  where
+    showArg arg = if ' ' `elem` arg then "'" ++ arg ++ "'" else arg
+
+-- | For parallel RGL module compilation
+-- Unfortunately, this has no effect unless 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]
+
+putErrLn :: String -> IO ()
+putErrLn = hPutStrLn stderr