1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
|
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 phrasebook project, and can be changed
-- to fit other projects.
modules = "Phrasebook":"Sentences":specifics
specifics = ["Words","Greetings"]
commons = ["Apple","Beer","Bread","Fish","Milk","Salt","Water","Wine",
"Bad","Cold","Good","Warm","AHasChildren"]
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
|
