GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-22 17:42:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

some fixes in grammar merging script

Browse Source
This commit is contained in:
aarne
2014-09-30 09:05:14 +00:00
parent 9fd8d5d019
commit e218c38bae
1 changed files with 14 additions and 14 deletions
Download Patch File Download Diff File Expand all files Collapse all files

28
lib/src/translator/MergeDict.hs
View File

@@ -35,24 +35,24 @@ mergeDict old new comm file = do
olds1 <- readFile old >>= return . lines olds1 <- readFile old >>= return . lines
news1 <- readFile new >>= return . lines news1 <- readFile new >>= return . lines
let (preamble,olds2) = break ((== ["lin"]) . take 1 . words) olds1 let (preamble,olds2) = break ((== ["lin"]) . take 1 . words) olds1
let olds = [mkRule (w:ws) | w:ws <- map words olds2, w == "lin"] let olds = [mkRule 0 (w:ws) | w:ws <- map words olds2, w == "lin"]
let news = [mkRule (w:ws) | w:ws <- map words news1, w == "lin"] let news = [mkRule 1 (w:ws) | w:ws <- map words news1, w == "lin"]
let lins = sort $ [(f,0) | f <- olds] ++ [(f,1) | f <- news] let lins = sort $ olds ++ news
let linss = groupBy (\x y -> (fun (fst x)) == (fun (fst y))) lins let linss = groupBy (\x y -> (fun x) == (fun y)) lins
let lins2 = map (mergeRule comm) linss let lins2 = map (mergeRule comm) linss
writeFile file $ unlines preamble writeFile file $ unlines preamble
appendFile file $ unlines $ map prRule lins2 appendFile file $ unlines $ map prRule lins2
appendFile file "}" appendFile file "}"
data Rule = R {fun :: String, lins :: [[String]], comment :: [String]} -- fun, variants, comment data Rule = R {fun :: String, priority :: Int, lins :: [[String]], comment :: [String]} -- fun, variants, comment
deriving (Eq,Ord) deriving (Eq,Ord)
mkRule :: [String] -> Rule mkRule :: Int -> [String] -> Rule
mkRule ws = case ws of mkRule i ws = case ws of
"lin":f:"=":ww -> rule f (getLin ww) "lin":f:"=":ww -> rule f i (getLin ww)
_ -> error $ "not a valid rule: " ++ unwords ws _ -> error $ "not a valid rule: " ++ unwords ws
where where
rule f (l,c) = R f l c rule f i (l,c) = R f i l c
getLin ws = case break isComment ws of getLin ws = case break isComment ws of
(ls,cc) -> (getVariants (init ls), cc) (ls,cc) -> (getVariants (init ls), cc)
getVariants ws = case break (=="|") ws of getVariants ws = case break (=="|") ws of
@@ -62,10 +62,10 @@ mkRule ws = case ws of
isEmpty v = elem v [["variants{}"],["variants","{}"]] isEmpty v = elem v [["variants{}"],["variants","{}"]]
isComment = (=="--") . take 2 isComment = (=="--") . take 2
mergeRule :: Maybe String -> [(Rule,Int)] -> Rule mergeRule :: Maybe String -> [Rule] -> Rule
mergeRule mco rs = case rs of mergeRule mco rs = case rs of
[(r,_)] -> r [r] -> r
[(old,_),(new,_)] -> R (fun old) (mergeLin (lins old) (lins new)) (comment old ++ comment new) [old,new] -> R (fun old) 0 (mergeLin (lins old) (lins new)) (comment old ++ comment new)
where where
mergeLin old new = olds ++ case filter (flip notElem old) new of mergeLin old new = olds ++ case filter (flip notElem old) new of
l:ls -> case mco of l:ls -> case mco of
@@ -74,7 +74,7 @@ mergeRule mco rs = case rs of
_ -> [] _ -> []
where where
olds = case old of olds = case old of
[[]] -> [["variants","{}"]] ---- [[]] -> [["variants","{}"]]
_ -> old _ -> old
prRule :: Rule -> String prRule :: Rule -> String
@@ -83,5 +83,5 @@ prRule ru = unwords $ "lin" : fun ru : "=" : variants ru ++ [";"] ++ comment ru
variants :: Rule -> [String] variants :: Rule -> [String]
variants ru = case lins ru of variants ru = case lins ru of
[[]] -> ["variants","{}"] [[]] -> ["variants","{}"]
ls -> intersperse "|" (map unwords ls) ls -> intersperse "|" (map unwords (filter (not . null) ls))