MainUDOnly.hs

module Main where

---import qualified UD2GF as U 
---import qualified GF2UD as G
import qualified DBNF as D
---import UDAnnotations
import UDOptions
import UDConcepts
---import GFConcepts (pAbsTree)
import UDVisualizationOnly
import UDAnalysisOnly
import UDPatternsOnly
import RTree

---import PGF

import System.Environment (getArgs)
import Control.Concurrent
import Control.Monad
import Data.List(sortOn, (\\))
import Data.Char(isDigit)

-- to get parallel processing:
-- Build with -threaded -rtsopts
-- Run with +RTS -N$cores -RTS

main = do
  xx <- getArgs
  case xx of

    "dbnf":grammarfile:startcat:opts -> D.processRuleBased grammarfile startcat opts

    "conll2svg":_ -> getContents >>= putStrLn . ud2svg . parseUDText
    
    "conll2latex":_ -> getContents >>= putStrLn . ud2latex . parseUDText
  
    "conll2pdf":_ -> getContents >>= visualizeUDSentences . parseUDText
  
    "check-treebank":_ -> getContents >>= putStrLn . checkUDSentences . parseUDText

---    "check-annotations":path:lang:cat:_ -> checkAnnotations path lang cat
    
    "statistics":opts -> getContents >>= mapM_ print . udFrequencies (selectOpts opts) . parseUDText

    "pattern-match":ws0 -> do
       let (opts,ws) = span (flip elem ["adjust","prune"]) ws0
       let sopts = selectOpts opts
       patterntext <- case ws of
         "-f":file:_ -> readFile file
         _ -> return $ unwords ws
       let pattern = (read patterntext) :: UDPattern
       ss <- getContents >>= return . parseUDText
       mapM_ putStrLn $ filter (not . null) $ map (showMatchesInUDSentence sopts pattern) ss
    
    "pattern-replace":ws -> do
       patterntext <- case ws of
         "-f":file:_ -> readFile file
         _ -> return $ unwords ws
       let pattern = (read patterntext) :: UDReplacement
       putStrLn $ "## " ++ show pattern
       ss <- getContents >>= return . parseUDText
       mapM_ putStrLn $ map (showReplacementsInUDSentence pattern) ss
    
    "cosine-similarity":file1:file2:opts -> do
      ud1 <- parseUDFile file1
      ud2 <- parseUDFile file2
      print $ udCosineSimilarity (selectOpts opts) ud1 ud2
  
    "cosine-similarity-sort":file1:file2:fopts -> do
      ud1 <- parseUDFile file1
      ud2 <- parseUDFile file2
      let (limit,opts) = case fopts of
             "-threshold":d:ropts | all isDigit d -> ((read d :: Double)/100, selectOpts ropts)
             _ -> (0, selectOpts fopts)
      let reference = udFrequencyMap opts ud1
      let results = [(ud,sim) |
            ud <- ud2,
            let udmap = udFrequencyMap opts [ud],
            let sim = cosineSimilarityOfMaps reference udmap
            ]
      let sortedResults = sortOn ((0-) . snd) (filter ((>= limit) . snd) results)
      flip mapM_ sortedResults $ \ (ud,sim) -> do
        putStrLn $ prt $ ud{udCommentLines = ("# similarity " ++ show sim) : udCommentLines ud}
  
    "not-covered":file1:file2:opts -> do
      ud1 <- parseUDFile file1
      ud2 <- parseUDFile file2
      putStrLn $ unwords $ map show $ notCoveredFeatures (selectOpts opts) ud1 ud2
  
---    "parse2latex":file:_ -> getContents >>= absTrees2latex initUDEnv file . map pAbsTree . selectParseTrees . lines
    
---    "parse2pdf":_ -> getContents >>= visualizeAbsTrees initUDEnv . map pAbsTree . selectParseTrees . lines

    "conll2tree":_ -> getContents >>= mapM_ putStrLn . map (prUDTree . udSentence2tree) . parseUDText
    "adjust-positions":_ -> getContents >>= mapM_ putStrLn . map (prt . udTree2sentence . createRoot . udSentence2tree . adjustUDIds) . parseUDText

    "conll2reduced":patt:_ -> getContents >>= mapM_ putStrLn . map (prReducedUDSentence patt) . parseUDText
    "reduced2conll":patt:_ -> getContents >>= mapM_ (putStrLn . prt) . map (pReducedUDSentence patt) . stanzas . lines
    "oneliner2conll":patt:_ -> getContents >>= mapM_ (putStrLn . prt) . map (pOneLineUDSentence patt) . lines
    
    "extract-pos-words":_ -> getContents >>= putStrLn . unlines . map ud2poswords . parseUDText
    "extract-pos-feats-words":_ -> getContents >>= putStrLn . unlines . map ud2posfeatswords . parseUDText

    "sample":n:_ -> getContents >>= mapM_ (putStrLn . prt) . sampleFromList (read n) . parseUDText
    "first":n:_ -> getContents >>= mapM_ (putStrLn . prt) . take (read n) . parseUDText
    "last":n:_ -> getContents >>= mapM_ (putStrLn . prt) . takeLast (read n) . parseUDText

    "immediate-subtrees":_ -> getContents >>= mapM_ (putStrLn . prt . udTree2sentence . adjustRootAndPositions) . concatMap (subtrees . udSentence2tree) . parseUDText

    "extract-dbnf":n:_ -> getContents >>= putStrLn . extractDBNF (read n)
    
    "calibrate-dbnf":tbfile:_ -> do
      tb  <- parseUDFile tbfile
      dbnf <- getContents >>= return . D.pGrammar
      let cdbnf = calibrateDBNF tb dbnf
      putStrLn $ D.prGrammar cdbnf

{-    
    "lexical-entries":annots:_ -> do
       env <- getAnnotEnv [annots]
       uds <- getContents >>= return . parseUDText
       let entries = lexicalEntries env uds
       putStrLn $ unlines [unwords [w ++ "_" ++ c, "--", show (reverse i)] | ((w,c),i) <- entries]
       
    "lexical-entries-gf":annots:pgf:_ -> do
       env <- getAnnotEnv [annots,pgf]
       uds <- getContents >>= return . parseUDText
       let entries = lexicalEntriesGF env uds
       putStrLn $ unlines entries
-}
    "eval":micmac:luas:goldf:testf:opts -> do
    
      putStrLn (unwords ("evaluating": tail xx))
      
      let mcro = case micmac of "macro" -> False ; "micro" -> True ; _ -> error ("expected micro|macro, got " ++ micmac)
      let crit = case luas of "LAS" -> agreeLAS ; "UAS" -> agreeUAS ; _ -> error ("expected LAS|UAS, got " ++ luas)
      
      gold <- parseUDFile goldf
      test <- parseUDFile testf

      case opts of
        _ | isOpt (selectOpts opts) "units" -> do
          let pairs = zip gold test
          let scores = sortOn (udScore . fst) [(snd (udSentenceScore crit go [te]), (go,te)) | (go,te) <- pairs]
          flip mapM_ scores $ \ (score,(go,te)) -> do
            print score
            putStrLn $ prUDAlign go te
          
        _ -> do
          let score = udCorpusScore mcro crit gold test
          print score
      
---    dir:path:lang:cat:opts | elem (dropWhile (=='-') dir) ["ud2gf","gf2ud","ud2gfparallel","string2gf2ud"] -> do
---      env <- getEnv path lang cat
---      convertGFUD (dropWhile (=='-') dir) (selectOpts opts) env
    _ -> putStrLn $ helpMsg

helpMsg = unlines $ [
    "Usage:",
    "   gfud check-treebank",
    " | gfud statistics <option>*",
    " | gfud pattern-match (adjust|prune)? ('<pattern>' | -f <file>)",
    " | gfud pattern-replace ('<replacement>' | -f <file>)",
    " | gfud cosine-similarity <file> <file> <option>*",
    " | gfud cosine-similarity-sort <file> <file> <option>*",
    " | gfud not-covered <standardfile> <testedfile> <option>*",
    " | gfud extract-pos-words",
    " | gfud extract-pos-feats-words",
    " | gfud lexical-entries <abslabels-file>",
    " | gfud lexical-entries-gf <abslabels-file> <morphodict-pgf-file>",
    " | gfud sample <int>",
    " | gfud first <int>",
    " | gfud last <int>",
    " | gfud immediate-subtrees",
    " | gfud conll2tree",
    " | gfud conll2reduced <reduce_pattern>",
    " | gfud reduced2conll <reduce_pattern>",
    " | gfud oneliner2conll <reduce_pattern>",
    " | gfud adjust-positions",
    " | gfud conll2pdf",
    " | gfud parse2pdf",
    " | gfud conll2latex",
    " | gfud conll2svg",
    " | gfud parse2latex <file>",
    " | gfud eval (micro|macro) (LAS|UAS) <goldfile> <testablefile> units?",
    " | gfud dbnf <dbnf-grammarfile> <startcat> <-cut=NUMBER>? <-show=NUMBER>? <-onlyparsetrees>?",
    " | gfud extract-dbnf <int>",
    " | gfud calibrate-dbnf <file>",
    " | gfud check-annotations <path> <language> <startcat>",
    " | gfud (ud2gf|gf2ud|string2gf2ud|ud2gfparallel) <path> <language> <startcat> <option>*",
    "where path = grammardir/abstractprefix, language = concretesuffix.",
    "The files read are <path>.pgf, <path>.labels, and <path><language>.labels.",
    "Except for <file> arguments, the input comes from stdIO, and the output goes there as well",
    "The option ud2gfparallel should be used with the Haskell runtime flag +RTS -Nx -RTS",
    "where x is the number of cores you want to use in parallel processing.",
    "For more functionalities: open MainUDGF.hs in ghci.",
    "Pattern syntax:" ,
    "   (FORM | LEMMA | POS | DEPREL | DEPREL_ | FEATS | FEATS_) <string>",
    " | ARG <pos> <deprel>",
    " | (AND | OR) [ <pattern>,* ]",
    " | (SEQUENCE | SEQUENCE_) [ <pattern>,* ]",
    " | NOT <pattern>",
    " | (TREE | TREE_) <pattern> <pattern>*",
    " | (DEPTH | DEPTH_UNDER | DEPTH_OVER) <int>",
    " | (LENGTH | LENGTH_UNDER | LENGTH_OVER) <int>",
    " | TRUE",
    " | PROJECTIVE",
    "where DEPREL_, FEATS_, SEQUENCW_, TREE_ mean matching a subset/substring.",
    "<string> arguments require double quotes, and the <pattern> itself is in single quotes",
    "if read from command line, but not if read from a file (the -f option).",
    "Replacement syntax:",
    "   (REPLACE_FORM | REPLACE_LEMMA | REPLACE_POS | REPLACE_DEPREL | REPLACE_DEPREL_) <string> <string>",
    " | (REPLACE_FEATS | REPLACE_FEATS_) <string> <string>",
    " | IF <pattern> <replacement>",
    " | UNDER <pattern> <replacement>",
    " | OVER <pattern> <replacement>",
    " | PRUNE <pattern> <int>",
    " | FILTER_SUBTREES <pattern> <pattern>",
    " | FLATTEN <pattern>",
    " | RETARGET <pattern> <pattern> <pattern>",
    " | CHANGES [ <replacement>,* ]",
    " | COMPOSE [ <replacement>,* ]",
    "<reduce_pattern> is a string such as xx_x__xx that hides the _ fields of UD words in conll2reduced.",
    "In reduced2conll it inserts _ to those fields to obtain legal CoNLL.",
    "In oneliner2conll xx_x__xx, each sentence is given as in '1 John NOUN 2 nsubj ; 2 walks VERB 0 root'.",
    "",
    "Options:"
    ] ++ ["  " ++ opt ++ "\t" ++ msg | (opt,msg) <- fullOpts]

{- ---
convertGFUD :: String -> Opts -> UDEnv -> IO ()
convertGFUD dir opts env = 
  let optsU2G = if null (opts \\ nonPrintingOpts) then opts ++ defaultOptsUD2GF else opts
  in case dir of
    "ud2gf" -> getContents >>= ud2gfOpts optsU2G env
    "ud2gfparallel" -> getContents >>= ud2gfOptsPar optsU2G env
    _ -> do
      s <- getContents
      let conv = case dir of
            "gf2ud" -> G.testTreeString
            "string2gf2ud" -> G.testString
      let os = if null opts then defaultOptsGF2UD else opts
      uds <- mapM (\ (i,s) -> conv i os env s) $ zip [1..] . filter (not . null) $ lines s
      case opts of
        _ | isOpt opts "lud" -> putStrLn $ ud2latex uds
        _ | isOpt opts "vud" -> visualizeUDSentences uds
        _ -> return ()
-}

---ud2gf :: UDEnv -> String -> IO ()
---ud2gf = ud2gfOpts defaultOptsUD2GF 

---ud2gfOpts :: Opts -> UDEnv -> String -> IO ()
---ud2gfOpts opts env = U.test opts env

---gf2ud :: UDEnv -> String -> IO ()
---gf2ud = gf2udOpts defaultOptsGF2UD 

---gf2udOpts :: Opts -> UDEnv -> String -> IO ()
---gf2udOpts opts env s = G.testString 1 opts env s >> return ()

---roundtripOpts :: Opts -> Opts -> UDEnv -> String -> IO ()
---roundtripOpts gopts uopts env s = do
---  putStrLn "FROM GF"
---  u <- G.testString 1 gopts env s
---  putStrLn "FROM UD BACK TO GF"
---  U.showUD2GF uopts env u
---  return ()

---roundtrip :: UDEnv -> String -> IO ()
---roundtrip = roundtripOpts defaultOptsGF2UD (selectOpts ["dt1","bt","at0","at","tc","lin"])

-- for quick use in ghci
mini = "grammars/MiniLang"
shallow = "grammars/ShallowParse"
term = "grammars/Term"
eng = "Eng"
utt = "Utt"
termInfix = "Infix"
termcat = "Term"

checkUDSentences :: [UDSentence] -> String
checkUDSentences uds = case errorsInUDSentences uds of
  [] -> "# treebank OK"
  msgs -> unlines msgs


sampleFromList n xs = take n [x | (x,i) <- zip xs [1..], mod i r == 0]
  where
    r = max 1 (div (length xs) n) 

takeLast n xs = drop (length xs - n) xs

{-
-------------------
---
ud2gfOptsPar :: Opts -> UDEnv -> String -> IO () --- [AbsTree]
ud2gfOptsPar opts env string = do
  let eng = actLanguage env
  let sentences = map prss $ stanzas $ lines string
  tstats <- manyLater (U.showUD2GF minimalOptsUD2GF env) sentences
  let globalStats = U.combineUD2GFStats $ map snd tstats
  ifOpt opts "stat" $ U.prUD2GFStat globalStats
---  if isOpt opts "vat" then (visualizeAbsTrees env (map expr2abstree (concatMap fst tstats))) else return ()
  return () --- return (map fst tstats)

splits n xs = case splitAt n xs of
  (x1,[])  -> [x1]
  (x1,xs2) -> x1 : splits n xs2

-- from Anton Ekblad 2020-01-09
manyLater :: (a -> IO b) -> [a] -> IO [b]
manyLater f chunks = do
  vs <- forM chunks $ \chunk -> do
    v <- newEmptyMVar
    forkIO $ do
      x <- f chunk
      x `seq` putMVar v x
    return v
  mapM takeMVar vs
-}