Merge pull request #370 from inariksit/morphodict

Minor improvements in MkMorphodict.hs + Finnish lexicon in new format

Author: aarneranta

src/finnish/NewDictFin.gf

@@ -19885,7 +19885,7 @@ lin moniaalle_Adv = mkAdv {s = c99 "moniaalle"} ;
 lin moniaalta_Adv = mkAdv {s = c99 "moniaalta"} ;
 lin monialaistua_V = mkV {s = c52 "monialaistua"} ;
 lin monias_N = mkN {s = d41 "monias"} ;
-lin moni_ilmeinen_N = mkN {s = d18 "moni-ilmeinen"} ;
+lin moni_ilmeinen_N = mkN {s = d38 "moni-ilmeinen"} ;
 lin monijumalaisuus_N = mkN {s = d40 "monijumalaisuus"} ;
 lin monikansainen_N = mkN {s = d38 "monikansainen"} ;
 lin monikko_N = mkN {s = d04A "monikko"} ;
@@ -41387,7 +41387,7 @@ lin ykkönen_N = mkN {s = d38 "ykkönen"} ;
 lin yks_Adv = mkAdv {s = c99 "yks"} ;
 lin ykseys_N = mkN {s = d40 "ykseys"} ;
 lin yksi_N = mkN {s = d31 "yksi"} ;
-lin yksi_ilmeinen_N = mkN {s = d18 "yksi-ilmeinen"} ;
+lin yksi_ilmeinen_N = mkN {s = d38 "yksi-ilmeinen"} ;
 lin yksiin_Adv = mkAdv {s = c99 "yksiin"} ;
 lin yksijumalaisuus_N = mkN {s = d40 "yksijumalaisuus"} ;
 lin yksikkö_N = mkN {s = d04A "yksikkö"} ;

src/morphodict/MkMorphodict.hs

@@ -5,7 +5,9 @@ import PGF
 import qualified Data.Map as M
 import Data.Char
 import Data.List
+import Safe
 import System.Environment (getArgs)
+import Debug.Trace
 
 -- AR 2020-02-28
 
@@ -28,29 +30,33 @@ usage = "runghc MkMorphodict (raw|pgf) <configfile> <datafile> <outfile>"
 main = do
   xx <- getArgs
   if length xx /= 4
-    then putStrLn usage
+    then do
+      putStrLn "Usage:"
+      putStrLn usage
+      putStrLn $ "Got instead: " ++ show xx
     else do
-      let mode:configfile:datafile:outfile:_ = xx 
+      let mode:configfile:datafile:outfile:_ = xx
       config <- readFile configfile >>= return . mkConfig
-  
+
       rawdata <- case mode of
         "pgf" -> pgfFile2rawData config datafile
-        "raw" -> readFile datafile >>= return . map getRawData . filter (not . null) . lines 
+        "raw" -> readFile datafile >>= return . map getRawData . filter (not . null) . lines
+        _ -> error $ "Expected mode (pgf|raw), got " ++ mode
       rawdata2gf config rawdata outfile
 
 
 rawdata2gf config rawdata outfile = do
-  
+
   let env = MDEnv rawdata config
   let (absrules,cncrules) = mkMorphoDict env
-  
+
   absheader <- readFile (outfile ++ "Abs.header")
   cncheader <- readFile (outfile ++ ".header")
-  
+
   writeFile (outfile ++ "Abs.gf") absheader
   appendFile (outfile ++ "Abs.gf") $ unlines $ sort absrules
   appendFile (outfile ++ "Abs.gf") "}"
-  
+
   writeFile (outfile ++ ".gf") cncheader
   appendFile (outfile ++ ".gf") $ unlines $ sort cncrules
   appendFile (outfile ++ ".gf") "}"
@@ -68,7 +74,7 @@ pgfFile2rawData config pgffile = do
         cat  <- cats,
         f    <- functionsByCat pgf (mkCId cat),
         lin  <- tabularLinearizes pgf lang (mkApp f [])
-    ] 
+    ]
 
 type Cat  = String
 type Fun  = String
@@ -84,12 +90,13 @@ mkConfig :: String -> Config  -- N : N mkN 0 2 4 6 # 9
 mkConfig ls = M.fromList [(c,i) | Left (c,i) <- map mkOne (lines ls)]
  where
   mkOne s = case words s of
-    "--":_                 -> Right s 
+    "--":_                 -> Right s
     cat:":":tcat:oper:ints -> Left (cat,(tcat,oper,mkArgs ints))
     _ -> Right s
   mkArgs ints = case break (=="#") ints of
-    (ss,[])   -> (map read ss, [])
-    (ss,_:fs) -> (map read ss, map read fs)
+    (ss,[])   -> (map read'  ss, [])
+    (ss,_:fs) -> (map read' ss, map read' fs)
+  read' a = readNote [] a -- Safe.readNote provides better error message
 
 getRawData s = case words s of
   c:cs -> (c,cs)
@@ -118,10 +125,13 @@ mkMorphoDict env =
     (([lemma],newcat),(oper, appSig sig args)) |
         (oldcat,args) <- raws,
         Just (newcat, oper, sig) <- [M.lookup oldcat (config env)],
-        let lemma = args !! head (fst sig)
-   ] 
+        let lemma = args `at` head (fst sig)
+   ]
 
-  appSig (ints,feats) args = ([args !! i | i <- ints], [args !! i | i <- feats])
+  appSig (ints,feats) args =
+    -- If there's wrong number in config file, uncomment the line below to see which number it should be
+    -- trace (intercalate "\n" $ map show (zip [0..] args)) $
+    ([args `at` i | i <- ints], [args `at` i | i <- feats])
 
   mergeRules :: [RawRule] -> [RawRule]
   mergeRules = map head . groupBy (\x y -> snd x == snd y) . sortOn snd
@@ -153,16 +163,20 @@ mkMorphoDict env =
     _ | length (nub (map tail fls)) == length fls -> shrinkMore (map tail fls)
     _ -> fls
 
-      
-mkFun = showCId . mkCId . concat . intersperse "_"
+-- >>> mkFun ["hello", "world", "hello friends", "hello-all"]
+-- "hello_world_hello_friends_hello_all"
+mkFun :: [String] -> String                          -- if word contains space or hyphen, replace with underscore
+mkFun = showCId . mkCId . concat . intersperse "_" . concatMap (words . removeHyphen)
+  where
+    removeHyphen [] = []
+    removeHyphen ['-'] = ['-'] -- If hyphen is the last character, it's usually meaningful, leave it
+    removeHyphen ('-':cs) = ' ' : removeHyphen cs
+    removeHyphen (c:cs) = c : removeHyphen cs
 
 quote s = "\"" ++ s ++ "\""
 
-
-
-
 {- ---- let us ignore this
-  findCompounds :: [RuleData] -> [RuleData] 
+  findCompounds :: [RuleData] -> [RuleData]
   findCompounds = getCompounds . sortOn cat_orthrevforms
 
   cat_orthrevforms (_,(cat,_:forms)) = (cat,[map (!!i) fss | let fss = map reverse forms, i <- [0..minimum (map length fss) - 1]])
@@ -171,9 +185,9 @@ quote s = "\"" ++ s ++ "\""
   revstem = head . snd . cat_revforms
   wforms (_,(_,_:forms)) = forms
 
-  getCompounds :: [RuleData] -> [RuleData] 
+  getCompounds :: [RuleData] -> [RuleData]
   getCompounds fls = case fls of
-    fl : fls1 | length (revstem fl) < 2 -> markWith fl [] : getCompounds fls1 
+    fl : fls1 | length (revstem fl) < 2 -> markWith fl [] : getCompounds fls1
     fl : fls2 -> case span (\x -> and [isPrefixOf (reverse w) (reverse w1) | (w,w1) <- zip (wforms fl) (wforms x)]) fls2 of
       ([],_:_) -> markWith fl [] : getCompounds fls2
       (fls1,fls3) -> markWith fl [] : map (markCompound fl) fls1 ++ getCompounds fls3
@@ -188,7 +202,7 @@ quote s = "\"" ++ s ++ "\""
 
   isPrefixWord x xy =
     length suff > 1 &&                                ---- compound first part must be at least two letters long
-    any (\c -> elem c "-0123456789aeiouyåäö") suff && ---- must contain a vowel or a digit 
+    any (\c -> elem c "-0123456789aeiouyåäö") suff && ---- must contain a vowel or a digit
     isPrefixOf x xy                                   ---- and of course be a prefix
    where
      suff = drop (length x) xy

src/morphodict/MorphoDictFin.config

@@ -0,0 +1,6 @@
+N : N mkN 0 1 2 4 7 13 14 16 17 19
+A : A mkA' 0 1 2 4 7 13 14 16 17 19
+V : V mkV  0 17 19 22 43 49 23 25 31 58 94 37
+V2 : V mkV 0 17 19 22 43 49 23 25 31 58 94 37
+Adv : Adv mkAdv 0
+Prep : Prep mkPrep 0