gf-rgl/Make.hs

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)
import System.FilePath ((</>),takeFileName,addExtension,dropExtension)
import System.Directory (createDirectoryIfMissing,copyFile,getDirectoryContents,removeDirectoryRecursive,findFile)
import Control.Monad (when,unless)

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 = getCommands 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)
  let files = getOptModules args
  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
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 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 $ "Copying [" ++ 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)

-------------------------------------------------------------------------------
-- 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
  } deriving (Show)

-- | 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  $ \modes args bi -> do
      putStrLn $ "Building [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 "modules"  False $ \modes args bi ->  do
      let modules = getOptModules args
      flip mapM_ modules $ \m -> do
        -- TODO determine dependants, e.g. include ExtraEngAbs when specifying ExtraEng
        mex <- findModule m
        case mex of
          Nothing -> die $ "Cannot find module: " ++ m
          Just mfull -> 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
  --         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

-- | Search all language dirs for module name
findModule :: String -> IO (Maybe FilePath)
findModule file = do
  let langdirs = map langDir langs
  let searchdirs = map ((</>) sourceDir) langdirs
  findFile searchdirs file

-- | Check arguments are valid, failing on error
checkArgs :: [String] -> IO ()
checkArgs args = do
  let args'' = args \\ (getOptModules args)
  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 argument: " ++ unwords args'
  return ()

-- | Get commands from args
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

-- | 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

-- | 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 module names from arguments
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

-- | 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 $ "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
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