diff --git a/lib/src/Clone.hs b/lib/src/Clone.hs new file mode 100644 index 000000000..9346aa740 --- /dev/null +++ b/lib/src/Clone.hs @@ -0,0 +1,67 @@ +module Main where + +import Control.Monad +import Data.Maybe +import Data.Char +import System.Cmd +import System.Directory +import System.Environment +import System.Exit + + +-- To clone a project from one language to another: +-- +-- 1. for each Module in 'modules', copy ModuleFROM to ModuleTO +-- 2. in each ModuleTO, replace substrings FROM by TO, if not prefixes of an Ident +-- 3. in each ModuleTO in 'specifics', comment out every line in the body, except +-- those whose first word is in 'commons'. +-- +-- Syntax: runghc Clone FROM TO +-- 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 + mapM_ (clone from to) modules + +clone from to pref = do + s <- readFile (pref ++ from ++ ".gf") + writeFile (pref ++ to ++ ".gf") (commentIf (isSpecific pref) (replaceLang from to s)) + +isSpecific = flip elem specifics + +replaceLang s1 s2 = repl where + repl s = case s of + c:cs -> case splitAt lgs s of + (pre,c:rest) | pre == s1 && elem c " \n\t,:=(){}.-[];" -> s2 ++ [c] ++ repl rest + _ -> c : repl cs + _ -> s + lgs = 3 -- length s1 + +-- the file name has the form p....pLLL.gf, i.e. 3-letter lang name, suffix .gf +getLangName fi = + let (nal,ferp) = splitAt 3 (drop 3 (reverse fi)) in + (reverse ferp,reverse nal) + +commentIf c = if c then (unlines . commentBody . lines) else id + +commentBody ss = header ++ map comment body ++ ["}"] where + (header,body) = break (isJment . words) ss + isJment ws = case ws of + k:_ | elem k ["flags","lin","lincat","oper","param"] -> True + _ -> False + 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