mirror of
https://github.com/GrammaticalFramework/gf-rgl.git
synced 2026-05-28 09:28:54 -06:00
Update Clone.hs to add copy api files and add language to config
This commit is contained in:
32
src/Clone.hs
32
src/Clone.hs
@@ -6,19 +6,24 @@ import Data.Char
|
|||||||
import Data.List
|
import Data.List
|
||||||
import System.Process
|
import System.Process
|
||||||
import System.Directory
|
import System.Directory
|
||||||
|
import System.FilePath
|
||||||
import System.Environment (getArgs)
|
import System.Environment (getArgs)
|
||||||
import System.Exit
|
import System.Exit
|
||||||
|
import Text.Printf
|
||||||
|
|
||||||
-- To clone a project from one language to another:
|
-- To clone a project from one language to another:
|
||||||
-- Clone fromdir todir fromlang tolang (--comment)
|
-- 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
|
-- 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
|
-- 2. in each Module(tolang), replace substrings fromlang by tolang, if proper suffixes of identifiers
|
||||||
-- 3. If the option --comment is present, comment out every line in the body
|
-- 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
|
-- Example: runghc Clone swedish danish Swe Dan
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
args <- getArgs
|
args <- getArgs
|
||||||
if length args < 4
|
if length args < 4
|
||||||
@@ -31,15 +36,32 @@ main = do
|
|||||||
createDirectoryIfMissing True todir
|
createDirectoryIfMissing True todir
|
||||||
mapM_ (clone options fromdir todir fromlang tolang) modules
|
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
|
clone options fromdir todir from to (absname,absfx) = do
|
||||||
s <- readFile (fromdir ++ "/" ++ absname ++ from ++ absfx ++ ".gf")
|
s <- readFile (fromdir ++ "/" ++ absname ++ from ++ absfx ++ ".gf")
|
||||||
writeAndReportFile (todir ++ "/" ++ absname ++ to ++ absfx ++ ".gf") (commentIf options (replaceLang from to s))
|
writeAndReportFile (todir ++ "/" ++ absname ++ to ++ absfx ++ ".gf") (commentIf options (replaceLang from to s))
|
||||||
|
|
||||||
|
getAbstractName :: String -> String -> (String, String)
|
||||||
getAbstractName from file
|
getAbstractName from file
|
||||||
| isSuffixOf (from ++ "Abs.gf") file = (take (length file - (length from + 6)) file, "Abs") -- (NewDict, Abs)
|
| 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, [])
|
| 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)
|
| 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
|
replaceLang s1 s2 = repl where
|
||||||
repl s = case s of
|
repl s = case s of
|
||||||
c:cs -> case splitAt lgs s of
|
c:cs -> case splitAt lgs s of
|
||||||
@@ -49,12 +71,14 @@ replaceLang s1 s2 = repl where
|
|||||||
_ -> s
|
_ -> s
|
||||||
lgs = length s1
|
lgs = length s1
|
||||||
|
|
||||||
|
commentIf :: [String] -> String -> String
|
||||||
commentIf options =
|
commentIf options =
|
||||||
let commentbody = if (elem "--comment-body" options) then commentBody else id
|
let commentbody = if (elem "--comment-body" options) then commentBody else id
|
||||||
dropcomments = if (elem "--drop-comments" options) then dropComments else id
|
dropcomments = if (elem "--drop-comments" options) then dropComments else id
|
||||||
in
|
in
|
||||||
unlines . commentbody . dropcomments . lines
|
unlines . commentbody . dropcomments . lines
|
||||||
|
|
||||||
|
commentBody :: [String] -> [String]
|
||||||
commentBody ss = header ++ map comment body ++ ["}"] where
|
commentBody ss = header ++ map comment body ++ ["}"] where
|
||||||
(header,body) = break (isJment . words) ss
|
(header,body) = break (isJment . words) ss
|
||||||
isJment ws = case ws of
|
isJment ws = case ws of
|
||||||
@@ -65,12 +89,14 @@ commentBody ss = header ++ map comment body ++ ["}"] where
|
|||||||
_ | all isSpace l -> l -- empty line
|
_ | all isSpace l -> l -- empty line
|
||||||
_ -> "--" ++ l
|
_ -> "--" ++ l
|
||||||
|
|
||||||
|
dropComments :: [String] -> [String]
|
||||||
dropComments = filter (not . isComment) where
|
dropComments = filter (not . isComment) where
|
||||||
isComment line = case dropWhile isSpace line of
|
isComment line = case dropWhile isSpace line of
|
||||||
'-':'-':'#':_ -> False
|
'-':'-':'#':_ -> False
|
||||||
'-':'-':_ -> True
|
'-':'-':_ -> True
|
||||||
_ -> False
|
_ -> False
|
||||||
|
|
||||||
|
writeAndReportFile :: FilePath -> String -> IO ()
|
||||||
writeAndReportFile file s = do
|
writeAndReportFile file s = do
|
||||||
writeFile file s
|
writeFile file s
|
||||||
putStrLn $ "wrote " ++ file
|
putStrLn $ "wrote " ++ file
|
||||||
|
|||||||
Reference in New Issue
Block a user