mirror of
https://github.com/GrammaticalFramework/gf-rgl.git
synced 2026-06-06 21:56:31 -06:00
103 lines
4.1 KiB
Haskell
103 lines
4.1 KiB
Haskell
module Main where
|
|
|
|
import Control.Monad
|
|
import Data.Maybe
|
|
import Data.Char
|
|
import Data.List
|
|
import System.Process
|
|
import System.Directory
|
|
import System.FilePath
|
|
import System.Environment (getArgs)
|
|
import System.Exit
|
|
import Text.Printf
|
|
|
|
-- To clone a project from one language to another:
|
|
-- Clone fromdir todir fromlang tolang
|
|
--
|
|
-- 1. for each Module in 'fromdir', copy Module(fromlang) to todir/Module(tolang) ; create todir if it doesn't exist
|
|
-- 2. in each Module(tolang), replace substrings fromlang by tolang, if proper suffixes of identifiers
|
|
-- 3. repeat the above for api/Module(fromlang) to api/Module(tolang)
|
|
-- 4. add the language to config file if not present
|
|
-- - If the option --comment-body is present, comment out every line in the body
|
|
-- - If the option --comment-body is present, comment out every line in the body
|
|
--
|
|
-- Example: runghc Clone swedish danish Swe Dan
|
|
|
|
main :: IO ()
|
|
main = do
|
|
args <- getArgs
|
|
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
|
|
|
|
mapM_ (\md -> clone options "api" "api" fromlang tolang (md,"")) apiModules
|
|
conf <- readFile configFile
|
|
if not (any (isPrefixOf tolang) (lines conf))
|
|
then do
|
|
appendFile configFile (printf "%s,%s\n" tolang todir)
|
|
printf "Language '%s' has been added to %s\n" tolang configFile
|
|
else return ()
|
|
|
|
configFile :: FilePath
|
|
configFile = ".." </> "languages.csv"
|
|
|
|
apiModules :: [String]
|
|
apiModules = ["Try","Symbolic","Syntax","Constructors","Combinators"]
|
|
|
|
clone :: [String] -> String -> String -> String -> String -> (String, String) -> IO ()
|
|
clone options fromdir todir from to (absname,absfx) = do
|
|
s <- readFile (fromdir ++ "/" ++ absname ++ from ++ absfx ++ ".gf")
|
|
writeAndReportFile (todir ++ "/" ++ absname ++ to ++ absfx ++ ".gf") (commentIf options (replaceLang from to s))
|
|
|
|
getAbstractName :: String -> String -> (String, String)
|
|
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 :: String -> String -> String -> String
|
|
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 = length s1
|
|
|
|
commentIf :: [String] -> String -> String
|
|
commentIf options =
|
|
let commentbody = if (elem "--comment-body" options) then commentBody else id
|
|
dropcomments = if (elem "--drop-comments" options) then dropComments else id
|
|
in
|
|
unlines . commentbody . dropcomments . lines
|
|
|
|
commentBody :: [String] -> [String]
|
|
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
|
|
_ -> "--" ++ l
|
|
|
|
dropComments :: [String] -> [String]
|
|
dropComments = filter (not . isComment) where
|
|
isComment line = case dropWhile isSpace line of
|
|
'-':'-':'#':_ -> False
|
|
'-':'-':_ -> True
|
|
_ -> False
|
|
|
|
writeAndReportFile :: FilePath -> String -> IO ()
|
|
writeAndReportFile file s = do
|
|
writeFile file s
|
|
putStrLn $ "wrote " ++ file
|