Update Clone.hs script for copying RGs (and other projects) to new langs

src/Clone.hs

@@ -3,57 +3,57 @@ module Main where
 import Control.Monad
 import Data.Maybe
 import Data.Char
-import System.Cmd
+import Data.List
+import System.Process
 import System.Directory
-import System.Environment
+import System.Environment (getArgs)
 import System.Exit
 
 
 -- To clone a project from one language to another:
+--   Clone fromdir todir fromlang tolang (--comment)
 --
--- 1. for each Module in 'modules', copy ModuleFROM to ModuleTO
+-- 1. for each Module in 'fromdir', copy Module(fromlang) to todir/Module(tolang) ; create todir if it doesn't exist
--- 2. in each ModuleTO, replace substrings FROM by TO, if not prefixes of an Ident
+-- 2. in each Module(tolang), replace substrings fromlang by tolang, if proper suffixes of identifiers
--- 3. in each ModuleTO in 'specifics', comment out every line in the body, except
+-- 3. If the option --comment is present, comment out every line in the body
---    those whose first word is in 'commons'.
 --
--- Syntax:  runghc Clone FROM TO
+-- Example: runghc Clone swedish danish Swe Dan
--- Example: runhugs Clone Swe Nor
-
--- The following lines are for the resource grammar project, and can be changed 
--- to fit other projects.
-
-modules = [
-  "Adjective", "Adverb", "Cat", "Conjunction", "Extra", "Grammar", "Idiom", "Lang", "Noun", "Numeral", 
-  "Phrase", "Question", "Relative", "Sentence", "Symbol", "Text", "Verb", 
-  "All", "Res", "Paradigms"] 
-   ++ specifics
-specifics = ["Lexicon","Structural"]
-commons = []
 
 main = do
-  from:to:_ <- getArgs
+  args <- getArgs
-  mapM_ (clone from to) modules
+  if length args < 4
+    then putStrLn "usage: Clone  (--comment-body|--drop-comments) fromdir todir fromlang tolang"
+    else do
+      let (options,[fromdir,todir,fromlang,tolang]) = span ((=='-') . head) args
+      allfromfiles   <- getDirectoryContents fromdir
+      let fromfiles = filter (\f -> isSuffixOf (fromlang ++ ".gf") f || isSuffixOf (fromlang ++ "Abs.gf") f) allfromfiles
+      let modules = map (getAbstractName fromlang) fromfiles
+      createDirectoryIfMissing True todir
+      mapM_ (clone options fromdir todir fromlang tolang) modules
 
-clone from to pref = do
+clone options fromdir todir from to (absname,absfx) = do
-  s <- readFile (pref ++ from ++ ".gf")
+  s <- readFile (fromdir ++ "/" ++ absname ++ from ++ absfx ++ ".gf")
-  writeFile (pref ++ to ++ ".gf") (commentIf (isSpecific pref) (replaceLang from to s))
+  writeAndReportFile (todir ++ "/" ++ absname ++ to ++ absfx ++ ".gf") (commentIf options (replaceLang from to s))
 
-isSpecific = flip elem specifics
+getAbstractName from file
+  | isSuffixOf (from ++ "Abs.gf") file = (take (length file - (length from + 6)) file, "Abs") -- (NewDict, Abs)
+  | isSuffixOf (from ++ ".gf") file = (take (length file - (length from + 3)) file, "") -- (NewDict, [])
+  | otherwise = error ("Need suffix " ++ (from ++ ".gf") ++ " or " ++ (from ++ "Abs.gf") ++ " therefore cannot clone file name " ++ file)
 
 replaceLang s1 s2 = repl where
   repl s = case s of
     c:cs -> case splitAt lgs s of
+      (pre,'A':'b':'s':c:rest) | pre == s1 && elem c " \n\t,:=(){}.-[];" -> s2 ++ "Abs" ++ [c] ++ repl rest
       (pre,c:rest) | pre == s1 && elem c " \n\t,:=(){}.-[];" -> s2 ++ [c] ++ repl rest
       _                      -> c : repl cs
     _ -> s
-  lgs = 3 -- length s1
+  lgs = length s1
 
--- the file name has the form p....pLLL.gf, i.e. 3-letter lang name, suffix .gf
+commentIf options =
-getLangName fi = 
+  let commentbody  = if (elem "--comment-body" options) then commentBody else id
-  let (nal,ferp) = splitAt 3 (drop 3 (reverse fi)) in 
+      dropcomments = if (elem "--drop-comments" options) then dropComments else id
-  (reverse ferp,reverse nal)  
+  in
-
+  unlines . commentbody . dropcomments . lines
-commentIf c = if c then (unlines . commentBody . lines) else id
 
 commentBody ss = header ++ map comment body ++ ["}"] where
   (header,body) = break (isJment . words) ss
@@ -63,5 +63,14 @@ commentBody ss = header ++ map comment body ++ ["}"] where
   comment l = case l of
     _ | take 2 l == "--" -> l                -- already commented
     _ | all isSpace l    -> l                -- empty line
-    _ | elem (head (words l)) commons -> l   -- in 'commons'
     _ -> "--" ++ l
+
+dropComments = filter (not . isComment) where
+  isComment line = case dropWhile isSpace line of
+    '-':'-':'#':_ -> False
+    '-':'-':_     -> True
+    _             -> False
+
+writeAndReportFile file s = do
+  writeFile file s
+  putStrLn $ "wrote " ++ file

src/MkLang.hs

@@ -1,49 +0,0 @@
-module Main where
-
--- Prepare a new resource directory. Usage:
--- 1. $ cp german/*.gf dutch/
--- 2. $ cd dutch/
--- 3. $ runghc ../MkLang.hs Ger Dut
--- AR 6/11/2009
-
-import System.Cmd
-import System.Environment
-import Data.List
-
-main = do
-  xx <- getArgs 
-  change xx
-
-change xx = case xx of
-  from:to:_ -> do
-     system "ls *.gf > files.tmp"
-     files <- readFile "files.tmp" >>= return . lines
-     mapM_ (changeFileName from to) files
-     system "ls *.gf > files.tmp"
-     files <- readFile "files.tmp" >>= return . lines
-     mapM_ (changeIdents from to) files
-----     mapM_ commentOut files
-  comment -> do
-     files <- readFile "files.tmp" >>= return . lines
-     mapM_ commentOut files
-
-changeFileName from to file = system $ "mv " ++ file ++ " " ++ to_file where
-  to_file = take (length file - 3 - length from) (takeWhile (/='.') file) ++ to ++ ".gf"
-
-changeIdents from to = changeInFile changes
- where
-   lg = length from
-   changes s = case s of
-     c:cs 
-       | take lg s == from -> to ++ changes (drop lg s)
-       | otherwise         -> c : changes cs
-     _ -> s
-
-commentOut = changeInFile comm where
-  comm s = let (hd,tl) = break (=='{') s in 
-    hd ++ "\n{\n" ++ unlines ["--" ++ l | l <- lines tl] ++ "\n}\n"
-
-changeInFile ch file = do
-  s <- readFile file
-  writeFile "gf.tmp" (ch s)
-  system $ "mv gf.tmp " ++ file