----------------------------------------------------------------------
-- |
-- Module      : VisualizeTree
-- Maintainer  : KA
-- Stability   : (stable)
-- Portability : (portable)
--
-- Print a graph of an abstract syntax tree in Graphviz DOT format
-- Based on BB's VisualizeGrammar
-----------------------------------------------------------------------------

module PGF.VisualizeTree
             ( GraphvizOptions(..)
             , graphvizDefaults
             , graphvizAbstractTree
             , graphvizParseTree
             , graphvizParseTreeDep
             , graphvizDependencyTree
             , Labels, getDepLabels
             , CncLabels, getCncDepLabels
             , graphvizBracketedString
             , graphvizAlignment
             , gizaAlignment
             , conlls2latexDoc
             ) where
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint

import PGF.CId (wildCId,showCId,ppCId,mkCId) --CId,pCId,
import PGF.Data
import PGF.Expr (Tree) -- showExpr
import PGF.Linearize
----import PGF.LatexVisualize (conll2latex) ---- should be separate module?
import PGF.Macros (lookValCat, BracketedString(..))
                   --lookMap, BracketedTokn(..), flattenBracketedString

import qualified Data.Map as Map
--import qualified Data.IntMap as IntMap
import Data.List (intersperse,nub,mapAccumL,find,groupBy,sortBy,partition)
import Data.Ord (comparing)
import Data.Char (isDigit)
import Data.Maybe (fromMaybe)
import Text.PrettyPrint

--import Data.Array.IArray
--import Control.Monad
--import qualified Data.Set as Set
--import qualified Text.ParserCombinators.ReadP as RP


data GraphvizOptions = GraphvizOptions {GraphvizOptions -> Bool
noLeaves :: Bool,
                                        GraphvizOptions -> Bool
noFun :: Bool,
                                        GraphvizOptions -> Bool
noCat :: Bool,
                                        GraphvizOptions -> Bool
noDep :: Bool,
                                        GraphvizOptions -> String
nodeFont :: String,
                                        GraphvizOptions -> String
leafFont :: String,
                                        GraphvizOptions -> String
nodeColor :: String,
                                        GraphvizOptions -> String
leafColor :: String,
                                        GraphvizOptions -> String
nodeEdgeStyle :: String,
                                        GraphvizOptions -> String
leafEdgeStyle :: String
                                       }

graphvizDefaults :: GraphvizOptions
graphvizDefaults = Bool
-> Bool
-> Bool
-> Bool
-> String
-> String
-> String
-> String
-> String
-> String
-> GraphvizOptions
GraphvizOptions Bool
False Bool
False Bool
False Bool
True String
"" String
"" String
"" String
"" String
"" String
""


-- | Renders abstract syntax tree in Graphviz format.
-- The pair of 'Bool' @(funs,cats)@ lets you control whether function names and
-- category names are included in the rendered tree.
graphvizAbstractTree :: PGF -> (Bool,Bool) -> Tree -> String
graphvizAbstractTree :: PGF -> (Bool, Bool) -> Tree -> String
graphvizAbstractTree PGF
pgf (Bool
funs,Bool
cats) = Doc -> String
render (Doc -> String) -> (Tree -> Doc) -> Tree -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree -> Doc
tree2graph
  where
    tree2graph :: Tree -> Doc
tree2graph Tree
t =
      String -> Doc
text String
"graph {" Doc -> Doc -> Doc
$$
      [CId] -> [Int] -> Int -> Tree -> Doc
ppGraph [] [] Int
0 Tree
t Doc -> Doc -> Doc
$$
      String -> Doc
text String
"}"

    getAbs :: [CId] -> Tree -> ([CId], Tree)
getAbs [CId]
xs (EAbs BindType
_ CId
x Tree
e) = [CId] -> Tree -> ([CId], Tree)
getAbs (CId
xCId -> [CId] -> [CId]
forall a. a -> [a] -> [a]
:[CId]
xs) Tree
e
    getAbs [CId]
xs (ETyped Tree
e Type
_) = [CId] -> Tree -> ([CId], Tree)
getAbs [CId]
xs Tree
e
    getAbs [CId]
xs Tree
e            = ([CId]
xs,Tree
e)

    getApp :: Tree -> [Tree] -> (Tree, [Tree])
getApp (EApp Tree
x (EImplArg Tree
y)) [Tree]
es = Tree -> [Tree] -> (Tree, [Tree])
getApp Tree
x [Tree]
es
    getApp (EApp Tree
x Tree
y)            [Tree]
es = Tree -> [Tree] -> (Tree, [Tree])
getApp Tree
x (Tree
yTree -> [Tree] -> [Tree]
forall a. a -> [a] -> [a]
:[Tree]
es)
    getApp (ETyped Tree
e Type
_)          [Tree]
es = Tree -> [Tree] -> (Tree, [Tree])
getApp Tree
e [Tree]
es
    getApp Tree
e                     [Tree]
es = (Tree
e,[Tree]
es)

    getLbl :: [CId] -> Tree -> Doc
getLbl [CId]
scope (EFun CId
f)     = let fun :: Doc
fun = if Bool
funs then CId -> Doc
ppCId CId
f else Doc
empty
                                    cat :: Doc
cat = if Bool
cats then CId -> Doc
ppCId (Abstr -> CId -> CId
lookValCat (PGF -> Abstr
abstract PGF
pgf) CId
f) else Doc
empty
                                    sep :: Doc
sep = if Bool
funs Bool -> Bool -> Bool
&& Bool
cats then Doc
colon else Doc
empty
                                in Doc
fun Doc -> Doc -> Doc
<+> Doc
sep Doc -> Doc -> Doc
<+> Doc
cat
    getLbl [CId]
scope (ELit Literal
l)     = String -> Doc
text (String -> String
escapeStr (Doc -> String
render (Literal -> Doc
ppLit Literal
l)))
    getLbl [CId]
scope (EMeta Int
i)    = Int -> Doc
ppMeta Int
i
    getLbl [CId]
scope (EVar Int
i)     = CId -> Doc
ppCId ([CId]
scope [CId] -> Int -> CId
forall a. [a] -> Int -> a
!! Int
i)
    getLbl [CId]
scope (ETyped Tree
e Type
_) = [CId] -> Tree -> Doc
getLbl [CId]
scope Tree
e
    getLbl [CId]
scope (EImplArg Tree
e) = [CId] -> Tree -> Doc
getLbl [CId]
scope Tree
e

    ppGraph :: [CId] -> [Int] -> Int -> Tree -> Doc
ppGraph [CId]
scope [Int]
ps Int
i Tree
e0 =
      let ([CId]
xs,  Tree
e1) = [CId] -> Tree -> ([CId], Tree)
getAbs [] Tree
e0
          (Tree
e2,[Tree]
args) = Tree -> [Tree] -> (Tree, [Tree])
getApp Tree
e1 []
          binds :: Doc
binds     = if [CId] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CId]
xs
                        then Doc
empty
                        else String -> Doc
text String
"\\\\" Doc -> Doc -> Doc
<> [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate Doc
comma ((CId -> Doc) -> [CId] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map CId -> Doc
ppCId [CId]
xs)) Doc -> Doc -> Doc
<+> String -> Doc
text String
"->"
          (Doc
lbl,[Tree]
eargs) = case Tree
e2 of
                          EAbs BindType
_ CId
_ Tree
_ -> (Char -> Doc
char Char
'@', Tree
e2Tree -> [Tree] -> [Tree]
forall a. a -> [a] -> [a]
:[Tree]
args) -- eta-redexes are rendered with artificial "@" node
                          Tree
_          -> ([CId] -> Tree -> Doc
getLbl [CId]
scope' Tree
e2, [Tree]
args)
          scope' :: [CId]
scope'    = [CId]
xs [CId] -> [CId] -> [CId]
forall a. [a] -> [a] -> [a]
++ [CId]
scope
      in [Int] -> Doc
ppNode (Int
iInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
ps) Doc -> Doc -> Doc
<> String -> Doc
text String
"[label =" Doc -> Doc -> Doc
<+> Doc -> Doc
doubleQuotes (Doc
binds Doc -> Doc -> Doc
<+> Doc
lbl) Doc -> Doc -> Doc
<> String -> Doc
text String
", style = \"solid\", shape = \"plaintext\"] ;" Doc -> Doc -> Doc
$$
         (if [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
ps
            then Doc
empty
            else [Int] -> Doc
ppNode [Int]
ps Doc -> Doc -> Doc
<+> String -> Doc
text String
"--" Doc -> Doc -> Doc
<+> [Int] -> Doc
ppNode (Int
iInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
ps) Doc -> Doc -> Doc
<+> String -> Doc
text String
"[style = \"solid\"];") Doc -> Doc -> Doc
$$
         [Doc] -> Doc
vcat ((Int -> Tree -> Doc) -> [Int] -> [Tree] -> [Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ([CId] -> [Int] -> Int -> Tree -> Doc
ppGraph [CId]
scope' (Int
iInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
ps)) [Int
0..] [Tree]
eargs)

    ppNode :: [Int] -> Doc
ppNode [Int]
ps = Char -> Doc
char Char
'n' Doc -> Doc -> Doc
<> [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
punctuate (Char -> Doc
char Char
'_') ((Int -> Doc) -> [Int] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Doc
int [Int]
ps))

    escapeStr :: String -> String
escapeStr []        = []
    escapeStr (Char
'\\':String
cs) = Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:String -> String
escapeStr String
cs
    escapeStr (Char
'"' :String
cs) = Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
'"' Char -> String -> String
forall a. a -> [a] -> [a]
:String -> String
escapeStr String
cs
    escapeStr (Char
c   :String
cs) = Char
c        Char -> String -> String
forall a. a -> [a] -> [a]
:String -> String
escapeStr String
cs


type Labels = Map.Map CId [String]

-- | Visualize word dependency tree.
graphvizDependencyTree
  :: String -- ^ Output format: @"latex"@, @"conll"@, @"malt_tab"@, @"malt_input"@ or @"dot"@
  -> Bool -- ^ Include extra information (debug)
  -> Maybe Labels -- ^ abstract label information obtained with 'getDepLabels'
  -> Maybe CncLabels -- ^ concrete label information obtained with ' ' (was: unused (was: @Maybe String@))
  -> PGF
  -> CId -- ^ The language of analysis
  -> Tree
  -> String -- ^ Rendered output in the specified format
graphvizDependencyTree :: String
-> Bool
-> Maybe Labels
-> Maybe CncLabels
-> PGF
-> CId
-> Tree
-> String
graphvizDependencyTree String
format Bool
debug Maybe Labels
mlab Maybe CncLabels
mclab PGF
pgf CId
lang Tree
t = 
  case String
format of
    String
"latex"      -> Doc -> String
render (Doc -> String) -> ([LaTeX] -> Doc) -> [LaTeX] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LaTeX] -> Doc
ppLaTeX ([LaTeX] -> String) -> [LaTeX] -> String
forall a b. (a -> b) -> a -> b
$ CoNLL -> [LaTeX]
conll2latex' CoNLL
conll
    String
"svg"        -> Doc -> String
render (Doc -> String) -> ([LaTeX] -> Doc) -> [LaTeX] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SVG] -> Doc
ppSVG ([SVG] -> Doc) -> ([LaTeX] -> [SVG]) -> [LaTeX] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LaTeX] -> [SVG]
toSVG ([LaTeX] -> String) -> [LaTeX] -> String
forall a b. (a -> b) -> a -> b
$ CoNLL -> [LaTeX]
conll2latex' CoNLL
conll
    String
"conll"      -> CoNLL -> String
printCoNLL CoNLL
conll
    String
"conllu"     -> CoNLL -> String
printCoNLL ([[String
"# text = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PGF -> CId -> Tree -> String
linearize PGF
pgf CId
lang Tree
t], [String
"# tree = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [CId] -> Tree -> String
showExpr [] Tree
t]] CoNLL -> CoNLL -> CoNLL
forall a. [a] -> [a] -> [a]
++ CoNLL
conll)
    String
"malt_tab"   -> Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat (([Doc] -> Doc) -> [[Doc]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ([Doc] -> Doc
hcat ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (Char -> Doc
char Char
'\t') ([Doc] -> [Doc]) -> ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\[Doc]
ws -> [[Doc]
ws [Doc] -> Int -> Doc
forall a. [a] -> Int -> a
!! Int
0,[Doc]
ws [Doc] -> Int -> Doc
forall a. [a] -> Int -> a
!! Int
1,[Doc]
ws [Doc] -> Int -> Doc
forall a. [a] -> Int -> a
!! Int
3,[Doc]
ws [Doc] -> Int -> Doc
forall a. [a] -> Int -> a
!! Int
6,[Doc]
ws [Doc] -> Int -> Doc
forall a. [a] -> Int -> a
!! Int
7])) [[Doc]]
wnodes)
    String
"malt_input" -> Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat (([Doc] -> Doc) -> [[Doc]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ([Doc] -> Doc
hcat ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (Char -> Doc
char Char
'\t') ([Doc] -> [Doc]) -> ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Doc] -> [Doc]
forall a. Int -> [a] -> [a]
take Int
6) [[Doc]]
wnodes)
    String
_            -> Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"digraph {" Doc -> Doc -> Doc
$$
                    Doc
space Doc -> Doc -> Doc
$$
                    Int -> Doc -> Doc
nest Int
2 (String -> Doc
text String
"rankdir=LR ;" Doc -> Doc -> Doc
$$
                            String -> Doc
text String
"node [shape = plaintext] ;" Doc -> Doc -> Doc
$$
                            [Doc] -> Doc
vcat [Doc]
nodes Doc -> Doc -> Doc
$$
                            [Doc] -> Doc
vcat [Doc]
links) Doc -> Doc -> Doc
$$
                    String -> Doc
text String
"}"
  where
    conll :: CoNLL
conll  = CncLabels -> CoNLL -> CoNLL
fixCoNLL (CncLabels
-> (CncLabels -> CncLabels) -> Maybe CncLabels -> CncLabels
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] CncLabels -> CncLabels
forall a. a -> a
id Maybe CncLabels
mclab) CoNLL
conll0
    conll0 :: CoNLL
conll0 = (([Doc] -> [String]) -> [[Doc]] -> CoNLL
forall a b. (a -> b) -> [a] -> [b]
map(([Doc] -> [String]) -> [[Doc]] -> CoNLL)
-> ((Doc -> String) -> [Doc] -> [String])
-> (Doc -> String)
-> [[Doc]]
-> CoNLL
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Doc -> String) -> [Doc] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map) Doc -> String
render [[Doc]]
wnodes
    nodes :: [Doc]
nodes  = (((CId, Int, CId, Int), Int, String) -> Doc)
-> [((CId, Int, CId, Int), Int, String)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((CId, Int, CId, Int), Int, String) -> Doc
forall a c d. ((a, Int, c, d), Int, String) -> Doc
mkNode [((CId, Int, CId, Int), Int, String)]
leaves
    links :: [Doc]
links  = ((Int, (String, Int)) -> Doc) -> [(Int, (String, Int))] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int, (String, Int)) -> Doc
mkLink [(Int
fid, (String, Int) -> Maybe (String, Int) -> (String, Int)
forall a. a -> Maybe a -> a
fromMaybe (String
dep_lbl,Int
nil) (Int -> [(Int, (String, Int))] -> Maybe (String, Int)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
fid [(Int, (String, Int))]
deps)) | ((CId
cat,Int
fid,CId
fun,Int
_),Int
_,String
w) <- [((CId, Int, CId, Int), Int, String)]
-> [((CId, Int, CId, Int), Int, String)]
forall a. [a] -> [a]
tail [((CId, Int, CId, Int), Int, String)]
leaves]

-- CoNLL format: ID FORM LEMMA PLEMMA POS PPOS FEAT PFEAT HEAD PHEAD DEPREL PDEPREL
-- P variants are automatically predicted rather than gold standard

    wnodes :: [[Doc]]
wnodes = [[Int -> Doc
int Int
i, String -> Doc
maltws String
ws, CId -> Doc
ppCId CId
fun, CId -> Doc
ppCId (CId -> CId
posCat CId
cat), CId -> Doc
ppCId CId
cat, Int -> Doc
int Int
lind, Int -> Doc
int Int
parent, String -> Doc
text String
lab, Doc
unspec, Doc
unspec] |
              ((CId
cat,Int
fid,CId
fun,Int
lind),Int
i,String
ws) <- [((CId, Int, CId, Int), Int, String)]
-> [((CId, Int, CId, Int), Int, String)]
forall a. [a] -> [a]
tail [((CId, Int, CId, Int), Int, String)]
leaves,
              let (String
lab,Int
parent) = (String, Int) -> Maybe (String, Int) -> (String, Int)
forall a. a -> Maybe a -> a
fromMaybe (String
dep_lbl,Int
0)
                                           (do (String
lbl,Int
fid) <- Int -> [(Int, (String, Int))] -> Maybe (String, Int)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
fid [(Int, (String, Int))]
deps
                                               ((CId, Int, CId, Int)
_,Int
i,String
_) <- (((CId, Int, CId, Int), Int, String) -> Bool)
-> [((CId, Int, CId, Int), Int, String)]
-> Maybe ((CId, Int, CId, Int), Int, String)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\((CId
_,Int
fid1,CId
_,Int
_),Int
i,String
_) -> Int
fid Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
fid1) [((CId, Int, CId, Int), Int, String)]
leaves
                                               (String, Int) -> Maybe (String, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
lbl,Int
i))
             ]
    maltws :: String -> Doc
maltws = String -> Doc
text (String -> Doc) -> (String -> String) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"+" ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words  -- no spaces in column 2

    nil :: Int
nil = -Int
1

    bss :: [BracketedString]
bss = PGF -> CId -> Tree -> [BracketedString]
bracketedLinearize PGF
pgf CId
lang Tree
t

    root :: (CId, Int, CId, Int)
root = (CId
wildCId,Int
nil,CId
wildCId,Int
0)

    leaves :: [((CId, Int, CId, Int), Int, String)]
leaves = ((CId, Int, CId, Int)
root,Int
0,String
root_lbl) ((CId, Int, CId, Int), Int, String)
-> [((CId, Int, CId, Int), Int, String)]
-> [((CId, Int, CId, Int), Int, String)]
forall a. a -> [a] -> [a]
: (Int
-> [((CId, Int, CId, Int), String)]
-> [((CId, Int, CId, Int), Int, String)]
forall t a c. (Num t, Eq a) => t -> [(a, c)] -> [(a, t, c)]
groupAndIndexIt Int
1 ([((CId, Int, CId, Int), String)]
 -> [((CId, Int, CId, Int), Int, String)])
-> ([BracketedString] -> [((CId, Int, CId, Int), String)])
-> [BracketedString]
-> [((CId, Int, CId, Int), Int, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BracketedString -> [((CId, Int, CId, Int), String)])
-> [BracketedString] -> [((CId, Int, CId, Int), String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((CId, Int, CId, Int)
-> BracketedString -> [((CId, Int, CId, Int), String)]
getLeaves (CId, Int, CId, Int)
root)) [BracketedString]
bss
    deps :: [(Int, (String, Int))]
deps   = let (Int
_,(Int
h,[(Int, (String, Int))]
deps)) = Int
-> [CId] -> Tree -> [Tree] -> (Int, (Int, [(Int, (String, Int))]))
forall a.
Num a =>
a -> [CId] -> Tree -> [Tree] -> (a, (a, [(a, (String, a))]))
getDeps Int
0 [] Tree
t []
             in (Int
h,(String
dep_lbl,Int
nil))(Int, (String, Int))
-> [(Int, (String, Int))] -> [(Int, (String, Int))]
forall a. a -> [a] -> [a]
:[(Int, (String, Int))]
deps

    groupAndIndexIt :: t -> [(a, c)] -> [(a, t, c)]
groupAndIndexIt t
id []          = []
    groupAndIndexIt t
id ((a
p,c
w):[(a, c)]
pws) = (a
p,t
id,c
w) (a, t, c) -> [(a, t, c)] -> [(a, t, c)]
forall a. a -> [a] -> [a]
: t -> [(a, c)] -> [(a, t, c)]
groupAndIndexIt (t
idt -> t -> t
forall a. Num a => a -> a -> a
+t
1) [(a, c)]
pws
---    groupAndIndexIt id ((p,w):pws) = let (ws,pws1) = collect pws
---                                     in (p,id,unwords (w:ws)) : groupAndIndexIt (id+1) pws1
      where
        collect :: [(a, a)] -> ([a], [(a, a)])
collect pws :: [(a, a)]
pws@((a
p1,a
w):[(a, a)]
pws1)
          | a
p a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
p1   = let ([a]
ws,[(a, a)]
pws2) = [(a, a)] -> ([a], [(a, a)])
collect [(a, a)]
pws1
                        in (a
wa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ws,[(a, a)]
pws2)
        collect [(a, a)]
pws   = ([],[(a, a)]
pws)

    getLeaves :: (CId, Int, CId, Int)
-> BracketedString -> [((CId, Int, CId, Int), String)]
getLeaves (CId, Int, CId, Int)
parent BracketedString
bs =
      case BracketedString
bs of
        Leaf String
w                           -> [((CId, Int, CId, Int)
parent,String
w)]
        Bracket CId
cat Int
fid Int
_ Int
lind CId
fun [Tree]
_ [BracketedString]
bss -> (BracketedString -> [((CId, Int, CId, Int), String)])
-> [BracketedString] -> [((CId, Int, CId, Int), String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((CId, Int, CId, Int)
-> BracketedString -> [((CId, Int, CId, Int), String)]
getLeaves (CId
cat,Int
fid,CId
fun,Int
lind)) [BracketedString]
bss

    mkNode :: ((a, Int, c, d), Int, String) -> Doc
mkNode ((a
_,Int
p,c
_,d
_),Int
i,String
w) =
      Int -> Doc
tag Int
p Doc -> Doc -> Doc
<+> Doc -> Doc
brackets (String -> Doc
text String
"label = " Doc -> Doc -> Doc
<> Doc -> Doc
doubleQuotes (Int -> Doc
int Int
i Doc -> Doc -> Doc
<> Char -> Doc
char Char
'.' Doc -> Doc -> Doc
<+> String -> Doc
text String
w)) Doc -> Doc -> Doc
<+> Doc
semi

    mkLink :: (Int, (String, Int)) -> Doc
mkLink (Int
x,(String
lbl,Int
y)) = Int -> Doc
tag Int
y Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> Int -> Doc
tag Int
x  Doc -> Doc -> Doc
<+> String -> Doc
text String
"[label = " Doc -> Doc -> Doc
<> Doc -> Doc
doubleQuotes (String -> Doc
text String
lbl) Doc -> Doc -> Doc
<> String -> Doc
text String
"] ;"

    labels :: Labels
labels  = Labels -> (Labels -> Labels) -> Maybe Labels -> Labels
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Labels
forall k a. Map k a
Map.empty Labels -> Labels
forall a. a -> a
id Maybe Labels
mlab
    clabels :: CncLabels
clabels = CncLabels
-> (CncLabels -> CncLabels) -> Maybe CncLabels -> CncLabels
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] CncLabels -> CncLabels
forall a. a -> a
id Maybe CncLabels
mclab

    posCat :: CId -> CId
posCat CId
cat = case CId -> Labels -> Maybe [String]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CId
cat Labels
labels of
        Just [String
p] -> String -> CId
mkCId String
p
        Maybe [String]
_ -> CId
cat

    getDeps :: a -> [CId] -> Tree -> [Tree] -> (a, (a, [(a, (String, a))]))
getDeps a
n_fid [CId]
xs (EAbs BindType
_ CId
x Tree
e) [Tree]
es = a -> [CId] -> Tree -> [Tree] -> (a, (a, [(a, (String, a))]))
getDeps a
n_fid (CId
xCId -> [CId] -> [CId]
forall a. a -> [a] -> [a]
:[CId]
xs) Tree
e      [Tree]
es
    getDeps a
n_fid [CId]
xs (EApp Tree
e1 Tree
e2) [Tree]
es = a -> [CId] -> Tree -> [Tree] -> (a, (a, [(a, (String, a))]))
getDeps a
n_fid [CId]
xs     Tree
e1 (Tree
e2Tree -> [Tree] -> [Tree]
forall a. a -> [a] -> [a]
:[Tree]
es)
    getDeps a
n_fid [CId]
xs (EImplArg Tree
e) [Tree]
es = a -> [CId] -> Tree -> [Tree] -> (a, (a, [(a, (String, a))]))
getDeps a
n_fid [CId]
xs     Tree
e      [Tree]
es
    getDeps a
n_fid [CId]
xs (ETyped Tree
e Type
_) [Tree]
es = a -> [CId] -> Tree -> [Tree] -> (a, (a, [(a, (String, a))]))
getDeps a
n_fid [CId]
xs     Tree
e      [Tree]
es
    getDeps a
n_fid [CId]
xs (EFun CId
f)     [Tree]
es = let (a
n_fid_1,[(a, [(a, (String, a))])]
ds) = a -> [CId] -> [Tree] -> (a, [(a, [(a, (String, a))])])
descend a
n_fid [CId]
xs [Tree]
es
                                           (Maybe (a, [(a, (String, a))])
mb_h, [(String, (a, [(a, (String, a))]))]
deps) = CId
-> [(a, [(a, (String, a))])]
-> (Maybe (a, [(a, (String, a))]),
    [(String, (a, [(a, (String, a))]))])
forall b. CId -> [b] -> (Maybe b, [(String, b)])
selectHead CId
f [(a, [(a, (String, a))])]
ds
                                       in case Maybe (a, [(a, (String, a))])
mb_h of
                                            Just (a
fid,[(a, (String, a))]
deps0) -> (a
n_fid_1a -> a -> a
forall a. Num a => a -> a -> a
+a
1,(a
fid,[(a, (String, a))]
deps0[(a, (String, a))] -> [(a, (String, a))] -> [(a, (String, a))]
forall a. [a] -> [a] -> [a]
++
                                                                                [(a
n_fid_1,(String
dep_lbl,a
fid))][(a, (String, a))] -> [(a, (String, a))] -> [(a, (String, a))]
forall a. [a] -> [a] -> [a]
++
                                                                                [[(a, (String, a))]] -> [(a, (String, a))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [(a
m,(String
lbl,a
fid))(a, (String, a)) -> [(a, (String, a))] -> [(a, (String, a))]
forall a. a -> [a] -> [a]
:[(a, (String, a))]
ds | (String
lbl,(a
m,[(a, (String, a))]
ds)) <- [(String, (a, [(a, (String, a))]))]
deps]))
                                            Maybe (a, [(a, (String, a))])
Nothing          -> (a
n_fid_1a -> a -> a
forall a. Num a => a -> a -> a
+a
1,(a
n_fid_1,[[(a, (String, a))]] -> [(a, (String, a))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [(a
m,(String
lbl,a
n_fid_1))(a, (String, a)) -> [(a, (String, a))] -> [(a, (String, a))]
forall a. a -> [a] -> [a]
:[(a, (String, a))]
ds | (String
lbl,(a
m,[(a, (String, a))]
ds)) <- [(String, (a, [(a, (String, a))]))]
deps]))
    getDeps a
n_fid [CId]
xs (EMeta Int
i)    [Tree]
es = (a
n_fida -> a -> a
forall a. Num a => a -> a -> a
+a
2,(a
n_fid,[]))
    getDeps a
n_fid [CId]
xs (EVar  Int
i)    [Tree]
_  = (a
n_fida -> a -> a
forall a. Num a => a -> a -> a
+a
2,(a
n_fid,[]))
    getDeps a
n_fid [CId]
xs (ELit Literal
l)     [] = (a
n_fida -> a -> a
forall a. Num a => a -> a -> a
+a
1,(a
n_fid,[]))

    descend :: a -> [CId] -> [Tree] -> (a, [(a, [(a, (String, a))])])
descend a
n_fid [CId]
xs [Tree]
es = (a -> Tree -> (a, (a, [(a, (String, a))])))
-> a -> [Tree] -> (a, [(a, [(a, (String, a))])])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (\a
n_fid Tree
e -> a -> [CId] -> Tree -> [Tree] -> (a, (a, [(a, (String, a))]))
getDeps a
n_fid [CId]
xs Tree
e []) a
n_fid [Tree]
es

    selectHead :: CId -> [b] -> (Maybe b, [(String, b)])
selectHead CId
f [b]
ds =
      case CId -> Labels -> Maybe [String]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CId
f Labels
labels of
        Just [String]
lbls -> [(String, b)] -> (Maybe b, [(String, b)])
forall a. [(String, a)] -> (Maybe a, [(String, a)])
extractHead ([String] -> [b] -> [(String, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
lbls [b]
ds)
        Maybe [String]
Nothing   -> [b] -> (Maybe b, [(String, b)])
forall b. [b] -> (Maybe b, [(String, b)])
extractLast [b]
ds
      where
        extractHead :: [(String, a)] -> (Maybe a, [(String, a)])
extractHead []    = (Maybe a
forall a. Maybe a
Nothing, [])
        extractHead (ld :: (String, a)
ld@(String
l,a
d):[(String, a)]
lds)
          | String
l String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
head_lbl = (a -> Maybe a
forall a. a -> Maybe a
Just a
d,[(String, a)]
lds)
          | Bool
otherwise     = let (Maybe a
mb_h,[(String, a)]
deps) = [(String, a)] -> (Maybe a, [(String, a)])
extractHead [(String, a)]
lds
                            in (Maybe a
mb_h,(String, a)
ld(String, a) -> [(String, a)] -> [(String, a)]
forall a. a -> [a] -> [a]
:[(String, a)]
deps)

        extractLast :: [b] -> (Maybe b, [(String, b)])
extractLast []    = (Maybe b
forall a. Maybe a
Nothing, [])
        extractLast (b
d:[b]
ds)
          | [b] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [b]
ds       = (b -> Maybe b
forall a. a -> Maybe a
Just b
d,[])
          | Bool
otherwise     = let (Maybe b
mb_h,[(String, b)]
deps) = [b] -> (Maybe b, [(String, b)])
extractLast [b]
ds
                            in (Maybe b
mb_h,(String
dep_lbl,b
d)(String, b) -> [(String, b)] -> [(String, b)]
forall a. a -> [a] -> [a]
:[(String, b)]
deps)

    dep_lbl :: String
dep_lbl  = String
"dep"
    head_lbl :: String
head_lbl = String
"head"
    root_lbl :: String
root_lbl = String
"root"
    unspec :: Doc
unspec   = String -> Doc
text String
"_"

-- auxiliaries for UD conversion  PK 15/12/2018 
rmcomments :: String -> String
rmcomments :: String -> String
rmcomments String
s = case String
s of
  Char
'-':Char
'-':String
_ -> []
  Char
'#':Char
'f':Char
'u':Char
'n':String
rest -> String -> String
rmcomments String
rest -- the new gf-ud format
  Char
'#':Char
'c':Char
'a':Char
't':String
rest -> String -> String
rmcomments String
rest
  Char
x:String
xs -> Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
rmcomments String
xs
  String
_ -> []
  

-- | Prepare lines obtained from a configuration file for labels for
-- use with 'graphvizDependencyTree'. Format per line /fun/ /label/@*@.
--- ignore other gf-ud annotatations than #fun and #cat at this point 
getDepLabels :: String -> Labels
getDepLabels :: String -> Labels
getDepLabels String
s = [(CId, [String])] -> Labels
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String -> CId
mkCId String
f,[String]
ls) | String
f:[String]
ls <- (String -> [String]) -> [String] -> CoNLL
forall a b. (a -> b) -> [a] -> [b]
map (String -> [String]
words (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
rmcomments) (String -> [String]
lines String
s), Bool -> Bool
not (String -> Char
forall a. [a] -> a
head String
f Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#')]

-- the old function, without dependencies
graphvizParseTree :: PGF -> Language -> GraphvizOptions -> Tree -> String
graphvizParseTree :: PGF -> CId -> GraphvizOptions -> Tree -> String
graphvizParseTree = Maybe Labels -> PGF -> CId -> GraphvizOptions -> Tree -> String
graphvizParseTreeDep Maybe Labels
forall a. Maybe a
Nothing

graphvizParseTreeDep :: Maybe Labels -> PGF -> Language -> GraphvizOptions -> Tree -> String
graphvizParseTreeDep :: Maybe Labels -> PGF -> CId -> GraphvizOptions -> Tree -> String
graphvizParseTreeDep Maybe Labels
mbl PGF
pgf CId
lang GraphvizOptions
opts Tree
tree = GraphvizOptions
-> Maybe Labels -> Tree -> [BracketedString] -> String
graphvizBracketedString GraphvizOptions
opts Maybe Labels
mbl Tree
tree ([BracketedString] -> String) -> [BracketedString] -> String
forall a b. (a -> b) -> a -> b
$ PGF -> CId -> Tree -> [BracketedString]
bracketedLinearize PGF
pgf CId
lang Tree
tree

graphvizBracketedString :: GraphvizOptions -> Maybe Labels -> Tree -> [BracketedString] -> String
graphvizBracketedString :: GraphvizOptions
-> Maybe Labels -> Tree -> [BracketedString] -> String
graphvizBracketedString GraphvizOptions
opts Maybe Labels
mbl Tree
tree [BracketedString]
bss = Doc -> String
render Doc
graphviz_code
    where
      graphviz_code :: Doc
graphviz_code
          = String -> Doc
text String
"graph {" Doc -> Doc -> Doc
$$
            String -> Doc
text String
node_style Doc -> Doc -> Doc
$$
            [Doc] -> Doc
vcat [Doc]
internal_nodes Doc -> Doc -> Doc
$$
            (if GraphvizOptions -> Bool
noLeaves GraphvizOptions
opts then Doc
empty
             else String -> Doc
text String
leaf_style Doc -> Doc -> Doc
$$
                  Doc
leaf_nodes
            ) Doc -> Doc -> Doc
$$ String -> Doc
text String
"}"

      leaf_style :: String
leaf_style = String -> String -> String -> String
mkOption String
"edge" String
"style" (GraphvizOptions -> String
leafEdgeStyle GraphvizOptions
opts) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                   String -> String -> String -> String
mkOption String
"edge" String
"color" (GraphvizOptions -> String
leafColor GraphvizOptions
opts) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                   String -> String -> String -> String
mkOption String
"node" String
"fontcolor" (GraphvizOptions -> String
leafColor GraphvizOptions
opts) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                   String -> String -> String -> String
mkOption String
"node" String
"fontname" (GraphvizOptions -> String
leafFont GraphvizOptions
opts) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                   String -> String -> String -> String
mkOption String
"node" String
"shape" String
"plaintext"

      node_style :: String
node_style = String -> String -> String -> String
mkOption String
"edge" String
"style" (GraphvizOptions -> String
nodeEdgeStyle GraphvizOptions
opts) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                   String -> String -> String -> String
mkOption String
"edge" String
"color" (GraphvizOptions -> String
nodeColor GraphvizOptions
opts) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                   String -> String -> String -> String
mkOption String
"node" String
"fontcolor" (GraphvizOptions -> String
nodeColor GraphvizOptions
opts) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                   String -> String -> String -> String
mkOption String
"node" String
"fontname" (GraphvizOptions -> String
nodeFont GraphvizOptions
opts) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                   String -> String -> String -> String
mkOption String
"node" String
"shape" String
nodeshape
          where nodeshape :: String
nodeshape | GraphvizOptions -> Bool
noFun GraphvizOptions
opts Bool -> Bool -> Bool
&& GraphvizOptions -> Bool
noCat GraphvizOptions
opts = String
"point"
                          | Bool
otherwise = String
"plaintext"

      mkOption :: String -> String -> String -> String
mkOption String
object String
optname String
optvalue
          | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
optvalue  = String
""
          | Bool
otherwise      = String
object String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
optname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
optvalue String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"]; "

      mkNode :: CId -> CId -> String
mkNode CId
fun CId
cat
          | GraphvizOptions -> Bool
noFun GraphvizOptions
opts = CId -> String
showCId CId
cat
          | GraphvizOptions -> Bool
noCat GraphvizOptions
opts = CId -> String
showCId CId
fun
          | Bool
otherwise  = CId -> String
showCId CId
fun String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CId -> String
showCId CId
cat

      nil :: Int
nil = -Int
1
      internal_nodes :: [Doc]
internal_nodes = [[(Int, Int, String)] -> Doc
mkLevel [(Int, Int, String)]
internals |
                        [(Int, Int, String)]
internals <- [(Int, BracketedString)] -> [[(Int, Int, String)]]
getInternals ((BracketedString -> (Int, BracketedString))
-> [BracketedString] -> [(Int, BracketedString)]
forall a b. (a -> b) -> [a] -> [b]
map ((,) Int
nil) [BracketedString]
bss),
                        Bool -> Bool
not ([(Int, Int, String)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Int, String)]
internals)]
      leaf_nodes :: Doc
leaf_nodes = [(Int, Int, String)] -> Doc
mkLevel [(Int
parent, Int
id, CId -> String -> String
mkLeafNode CId
cat String
word) |
                            (Int
id, (Int
parent, (CId
cat,String
word))) <- [Int] -> [(Int, (CId, String))] -> [(Int, (Int, (CId, String)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
100000..] ((BracketedString -> [(Int, (CId, String))])
-> [BracketedString] -> [(Int, (CId, String))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CId -> Int -> BracketedString -> [(Int, (CId, String))]
getLeaves (String -> CId
mkCId String
"?") Int
nil) [BracketedString]
bss)]

      getInternals :: [(Int, BracketedString)] -> [[(Int, Int, String)]]
getInternals []    = []
      getInternals [(Int, BracketedString)]
nodes
          = [(Int, Int, String)] -> [(Int, Int, String)]
forall a. Eq a => [a] -> [a]
nub [(Int
parent, Int
fid, CId -> CId -> String
mkNode CId
fun CId
cat) |
                 (Int
parent, Bracket CId
cat Int
fid Int
_ Int
_ CId
fun [Tree]
_ [BracketedString]
_) <- [(Int, BracketedString)]
nodes]
            [(Int, Int, String)]
-> [[(Int, Int, String)]] -> [[(Int, Int, String)]]
forall a. a -> [a] -> [a]
: [(Int, BracketedString)] -> [[(Int, Int, String)]]
getInternals [(Int
fid, BracketedString
child) |
                            (Int
_, Bracket CId
_ Int
fid Int
_ Int
_ CId
_ [Tree]
_ [BracketedString]
children) <- [(Int, BracketedString)]
nodes,
                            BracketedString
child <- [BracketedString]
children]

      getLeaves :: CId -> Int -> BracketedString -> [(Int, (CId, String))]
getLeaves CId
cat Int
parent (Leaf String
word) = [(Int
parent, (CId
cat, String
word))] -- the lowest cat before the word
      getLeaves CId
_ Int
parent (Bracket CId
cat Int
fid Int
_ Int
i CId
_ [Tree]
_ [BracketedString]
children)
          = (BracketedString -> [(Int, (CId, String))])
-> [BracketedString] -> [(Int, (CId, String))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CId -> Int -> BracketedString -> [(Int, (CId, String))]
getLeaves CId
cat Int
fid) [BracketedString]
children

      mkLevel :: [(Int, Int, String)] -> Doc
mkLevel [(Int, Int, String)]
nodes
          = String -> Doc
text String
"subgraph {rank=same;" Doc -> Doc -> Doc
$$
            Int -> Doc -> Doc
nest Int
2 (-- the following gives the name of the node and its label:
                    [Doc] -> Doc
vcat [Int -> Doc
tag Int
id Doc -> Doc -> Doc
<> String -> Doc
text (String -> String -> String -> String
mkOption String
"" String
"label" String
lbl) | (Int
_, Int
id, String
lbl) <- [(Int, Int, String)]
nodes] Doc -> Doc -> Doc
$$
                    -- the following is for fixing the order between the children:
                    (if [(Int, Int, String)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Int, String)]
nodes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then
                         String -> Doc
text (String -> String -> String -> String
mkOption String
"edge" String
"style" String
"invis") Doc -> Doc -> Doc
$$
                         [Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (String -> Doc
text String
" -- ") [Int -> Doc
tag Int
id | (Int
_, Int
id, String
_) <- [(Int, Int, String)]
nodes]) Doc -> Doc -> Doc
<+> Doc
semi
                     else Doc
empty)
                   ) Doc -> Doc -> Doc
$$
            String -> Doc
text String
"}" Doc -> Doc -> Doc
$$
            -- the following is for the edges between parent and children:
            [Doc] -> Doc
vcat [Int -> Doc
tag Int
pid Doc -> Doc -> Doc
<> String -> Doc
text String
" -- " Doc -> Doc -> Doc
<> Int -> Doc
tag Int
id Doc -> Doc -> Doc
<> String -> Doc
text ((Int, Int, String) -> String
forall a c. (a, Int, c) -> String
depLabel (Int, Int, String)
node) | node :: (Int, Int, String)
node@(Int
pid, Int
id, String
_) <- [(Int, Int, String)]
nodes, Int
pid Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
nil] Doc -> Doc -> Doc
$$
            Doc
space

      depLabel :: (a, Int, c) -> String
depLabel node :: (a, Int, c)
node@(a
parent,Int
id,c
lbl) 
        | GraphvizOptions -> Bool
noDep GraphvizOptions
opts = String
";"
        | Bool
otherwise = case Int -> Maybe (CId, Int)
getArg Int
id of
            Just (CId
fun,Int
arg) -> String -> String -> String -> String
mkOption String
"" String
"label" (CId -> Int -> String
lookLabel CId
fun Int
arg) 
            Maybe (CId, Int)
_ -> String
";"
      getArg :: Int -> Maybe (CId, Int)
getArg Int
i = Int -> NumTree -> Maybe (CId, Int) -> Maybe (CId, Int)
getArgumentPlace Int
i (Tree -> NumTree
expr2numtree Tree
tree) Maybe (CId, Int)
forall a. Maybe a
Nothing

      labels :: Labels
labels = Labels -> (Labels -> Labels) -> Maybe Labels -> Labels
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Labels
forall k a. Map k a
Map.empty Labels -> Labels
forall a. a -> a
id Maybe Labels
mbl

      lookLabel :: CId -> Int -> String
lookLabel CId
fun Int
arg = case CId -> Labels -> Maybe [String]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CId
fun Labels
labels of
        Just [String]
xx | [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
xx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
arg -> case [String]
xx [String] -> Int -> String
forall a. [a] -> Int -> a
!! Int
arg of
          String
"head" -> String
""
          String
l -> String
l
        Maybe [String]
_ -> CId -> Int -> String
forall a p. (Eq a, Num a, Show a) => p -> a -> String
argLabel CId
fun Int
arg
      argLabel :: p -> a -> String
argLabel p
fun a
arg = if a
arga -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
0 then String
"" else String
"dep#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
arg --showCId fun ++ "#" ++ show arg
                         -- assuming the arg is head, if no configuration is given; always true for 1-arg funs
      mkLeafNode :: CId -> String -> String
mkLeafNode CId
cat String
word
       | GraphvizOptions -> Bool
noDep GraphvizOptions
opts = String
word        --- || not (noCat opts) -- show POS only if intermediate nodes hidden
       | Bool
otherwise = CId -> String
posCat CId
cat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
word         -- show POS in dependency tree

      posCat :: CId -> String
posCat CId
cat = case CId -> Labels -> Maybe [String]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CId
cat Labels
labels of
        Just [String
p] -> String
p
        Maybe [String]
_ -> CId -> String
showCId CId
cat

---- to restore the argument place from bracketed linearization
data NumTree = NumTree Int CId [NumTree]

getArgumentPlace :: Int -> NumTree -> Maybe (CId,Int) -> Maybe (CId,Int)
getArgumentPlace :: Int -> NumTree -> Maybe (CId, Int) -> Maybe (CId, Int)
getArgumentPlace Int
i tree :: NumTree
tree@(NumTree Int
int CId
fun [NumTree]
ts) Maybe (CId, Int)
mfi
 | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
int  = Maybe (CId, Int)
mfi
 | Bool
otherwise = case [(CId, Int)
fj | (NumTree
t,Int
x) <- [NumTree] -> [Int] -> [(NumTree, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [NumTree]
ts [Int
0..], Just (CId, Int)
fj <- [Int -> NumTree -> Maybe (CId, Int) -> Maybe (CId, Int)
getArgumentPlace Int
i NumTree
t ((CId, Int) -> Maybe (CId, Int)
forall a. a -> Maybe a
Just (CId
fun,Int
x))]] of
     (CId, Int)
fj:[(CId, Int)]
_ -> (CId, Int) -> Maybe (CId, Int)
forall a. a -> Maybe a
Just (CId, Int)
fj
     [(CId, Int)]
_ -> Maybe (CId, Int)
forall a. Maybe a
Nothing

expr2numtree :: Expr -> NumTree
expr2numtree :: Tree -> NumTree
expr2numtree = (NumTree, Int) -> NumTree
forall a b. (a, b) -> a
fst ((NumTree, Int) -> NumTree)
-> (Tree -> (NumTree, Int)) -> Tree -> NumTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> NumTree -> (NumTree, Int)
renumber Int
0 (NumTree -> (NumTree, Int))
-> (Tree -> NumTree) -> Tree -> (NumTree, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree -> NumTree
flatten where
  flatten :: Tree -> NumTree
flatten Tree
e = case Tree
e of
    EApp Tree
f Tree
a -> case Tree -> NumTree
flatten Tree
f of
      NumTree Int
_ CId
g [NumTree]
ts -> Int -> CId -> [NumTree] -> NumTree
NumTree Int
0 CId
g ([NumTree]
ts [NumTree] -> [NumTree] -> [NumTree]
forall a. [a] -> [a] -> [a]
++ [Tree -> NumTree
flatten Tree
a])
    EFun CId
f -> Int -> CId -> [NumTree] -> NumTree
NumTree Int
0 CId
f []
  renumber :: Int -> NumTree -> (NumTree, Int)
renumber Int
i t :: NumTree
t@(NumTree Int
_ CId
f [NumTree]
ts) = case Int -> [NumTree] -> ([NumTree], Int)
renumbers Int
i [NumTree]
ts of
    ([NumTree]
ts',Int
j) -> (Int -> CId -> [NumTree] -> NumTree
NumTree Int
j CId
f [NumTree]
ts', Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
  renumbers :: Int -> [NumTree] -> ([NumTree], Int)
renumbers Int
i [NumTree]
ts = case [NumTree]
ts of
    NumTree
t:[NumTree]
tt -> case Int -> NumTree -> (NumTree, Int)
renumber Int
i NumTree
t of
      (NumTree
t',Int
j) -> case Int -> [NumTree] -> ([NumTree], Int)
renumbers Int
j [NumTree]
tt of ([NumTree]
tt',Int
k) -> (NumTree
t'NumTree -> [NumTree] -> [NumTree]
forall a. a -> [a] -> [a]
:[NumTree]
tt',Int
k)
    [NumTree]
_ -> ([],Int
i)
----- end this terrible stuff AR 4/11/2015
 



type Rel = (Int,[Int])
-- possibly needs changes after clearing about many-to-many on this level

type IndexedSeq = (Int,[String])
type LangSeq = [IndexedSeq]

data PreAlign = PreAlign [LangSeq] [[Rel]]
  deriving Int -> PreAlign -> String -> String
[PreAlign] -> String -> String
PreAlign -> String
(Int -> PreAlign -> String -> String)
-> (PreAlign -> String)
-> ([PreAlign] -> String -> String)
-> Show PreAlign
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [PreAlign] -> String -> String
$cshowList :: [PreAlign] -> String -> String
show :: PreAlign -> String
$cshow :: PreAlign -> String
showsPrec :: Int -> PreAlign -> String -> String
$cshowsPrec :: Int -> PreAlign -> String -> String
Show
-- alignment structure for a phrase in 2 languages, along with the
-- many-to-many relations


genPreAlignment :: PGF -> [Language] -> Expr -> PreAlign
genPreAlignment :: PGF -> [CId] -> Tree -> PreAlign
genPreAlignment PGF
pgf [CId]
langs = [[BracketedString]] -> PreAlign
lin2align ([[BracketedString]] -> PreAlign)
-> (Tree -> [[BracketedString]]) -> Tree -> PreAlign
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree -> [[BracketedString]]
linsBracketed
 where
      linsBracketed :: Tree -> [[BracketedString]]
linsBracketed Tree
t = [PGF -> CId -> Tree -> [BracketedString]
bracketedLinearize PGF
pgf CId
lang Tree
t | CId
lang <- [CId]
langs]

      lin2align :: [[BracketedString]] -> PreAlign
      lin2align :: [[BracketedString]] -> PreAlign
lin2align [[BracketedString]]
bsss =  [LangSeq] -> [[Rel]] -> PreAlign
PreAlign [LangSeq]
langSeqs [[Rel]]
langRels
          where
           ([LangSeq]
langSeqs,[[Rel]]
langRels) = [[(Int, Int, String)]] -> ([LangSeq], [[Rel]])
forall a a a. Eq a => [[(a, a, a)]] -> ([[(a, [a])]], [[(a, [a])]])
mkLayers [[(Int, Int, String)]]
leaves
           nil :: Int
nil = -Int
1
           leaves :: [[(Int, Int, String)]]
leaves = ([BracketedString] -> [(Int, Int, String)])
-> [[BracketedString]] -> [[(Int, Int, String)]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [(Int, String)] -> [(Int, Int, String)]
forall t a. (Num t, Eq a) => t -> [(a, String)] -> [(a, t, String)]
groupAndIndexIt Int
0 ([(Int, String)] -> [(Int, Int, String)])
-> ([BracketedString] -> [(Int, String)])
-> [BracketedString]
-> [(Int, Int, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BracketedString -> [(Int, String)])
-> [BracketedString] -> [(Int, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> BracketedString -> [(Int, String)]
getLeaves Int
nil)) [[BracketedString]]
bsss

           groupAndIndexIt :: t -> [(a, String)] -> [(a, t, String)]
groupAndIndexIt t
id []          = []
           groupAndIndexIt t
id ((a
p,String
w):[(a, String)]
pws) = let ([String]
ws,[(a, String)]
pws1) = [(a, String)] -> ([String], [(a, String)])
forall a. [(a, a)] -> ([a], [(a, a)])
collect [(a, String)]
pws
                                             in (a
p,t
id,[String] -> String
unwords (String
wString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
ws)) (a, t, String) -> [(a, t, String)] -> [(a, t, String)]
forall a. a -> [a] -> [a]
: t -> [(a, String)] -> [(a, t, String)]
groupAndIndexIt (t
idt -> t -> t
forall a. Num a => a -> a -> a
+t
1) [(a, String)]
pws1
            where
              collect :: [(a, a)] -> ([a], [(a, a)])
collect pws :: [(a, a)]
pws@((a
p1,a
w):[(a, a)]
pws1)
                | a
p a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
p1   = let ([a]
ws,[(a, a)]
pws2) = [(a, a)] -> ([a], [(a, a)])
collect [(a, a)]
pws1
                                in (a
wa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ws,[(a, a)]
pws2)
              collect [(a, a)]
pws   = ([],[(a, a)]
pws)

           getLeaves :: Int -> BracketedString -> [(Int, String)]
getLeaves Int
parent BracketedString
bs =
                  case BracketedString
bs of
                    Leaf String
w                    -> [(Int
parent,String
w)]
                    Bracket CId
_ Int
fid Int
_ Int
_ CId
_ [Tree]
_ [BracketedString]
bss -> (BracketedString -> [(Int, String)])
-> [BracketedString] -> [(Int, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> BracketedString -> [(Int, String)]
getLeaves Int
fid) [BracketedString]
bss

           mkLayers :: [[(a, a, a)]] -> ([[(a, [a])]], [[(a, [a])]])
mkLayers ([(a, a, a)]
cs:[(a, a, a)]
css:[[(a, a, a)]]
rest) = let ([[(a, [a])]]
lrest, [[(a, [a])]]
rrest) =  [[(a, a, a)]] -> ([[(a, [a])]], [[(a, [a])]])
mkLayers ([(a, a, a)]
css[(a, a, a)] -> [[(a, a, a)]] -> [[(a, a, a)]]
forall a. a -> [a] -> [a]
:[[(a, a, a)]]
rest)
                                     in (([(a, a, a)] -> [(a, [a])]
forall a a a. [(a, a, a)] -> [(a, [a])]
fields [(a, a, a)]
cs) [(a, [a])] -> [[(a, [a])]] -> [[(a, [a])]]
forall a. a -> [a] -> [a]
: [[(a, [a])]]
lrest, (((a, a, a) -> (a, [a])) -> [(a, a, a)] -> [(a, [a])]
forall a b. (a -> b) -> [a] -> [b]
map ([(a, a, a)] -> (a, a, a) -> (a, [a])
forall a a c a c. Eq a => [(a, a, c)] -> (a, a, c) -> (a, [a])
mkLinks [(a, a, a)]
css) [(a, a, a)]
cs) [(a, [a])] -> [[(a, [a])]] -> [[(a, [a])]]
forall a. a -> [a] -> [a]
: [[(a, [a])]]
rrest)
           mkLayers [[(a, a, a)]
cs] = ([[(a, a, a)] -> [(a, [a])]
forall a a a. [(a, a, a)] -> [(a, [a])]
fields [(a, a, a)]
cs], [])
           mkLayers [[(a, a, a)]]
_ = ([],[])

           mkLinks :: [(a, a, c)] -> (a, a, c) -> (a, [a])
mkLinks [(a, a, c)]
cs (a
p0,a
id0,c
_) = (a
id0,[a]
indices)
                    where
                     indices :: [a]
indices = [a
id1 | (a
p1,a
id1,c
_) <- [(a, a, c)]
cs, a
p1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
p0]

           fields :: [(a, a, a)] -> [(a, [a])]
fields [(a, a, a)]
cs = [(a
id, [a
w]) | (a
_,a
id,a
w) <- [(a, a, a)]
cs]


-- we assume we have 2 languages - source and target
gizaAlignment :: PGF -> (Language,Language) -> Expr -> (String,String,String)
gizaAlignment :: PGF -> (CId, CId) -> Tree -> (String, String, String)
gizaAlignment PGF
pgf (CId
l1,CId
l2) Tree
e = let PreAlign [LangSeq
rl1,LangSeq
rl2] [[Rel]]
rels = PGF -> [CId] -> Tree -> PreAlign
genPreAlignment PGF
pgf [CId
l1,CId
l2] Tree
e
                                   in
                                     ([String] -> String
unwords (((Int, [String]) -> String) -> LangSeq -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int, [String]) -> String
forall a. (a, [String]) -> String
showIndSeq LangSeq
rl1), [String] -> String
unwords (CoNLL -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (CoNLL -> [String]) -> CoNLL -> [String]
forall a b. (a -> b) -> a -> b
$ ((Int, [String]) -> [String]) -> LangSeq -> CoNLL
forall a b. (a -> b) -> [a] -> [b]
map (Int, [String]) -> [String]
forall a b. (a, b) -> b
snd LangSeq
rl2),
                                        [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String]
words (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ LangSeq -> [Rel] -> String
forall (t :: * -> *) a a.
(Foldable t, Eq a, Show a) =>
[(a, t String)] -> [(a, [a])] -> String
showRels LangSeq
rl2 ([[Rel]] -> [Rel]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Rel]]
rels))


showIndSeq :: (a, [String]) -> String
showIndSeq (a
_,[String]
l) = let ww :: CoNLL
ww = (String -> [String]) -> [String] -> CoNLL
forall a b. (a -> b) -> [a] -> [b]
map String -> [String]
words [String]
l
                       w_ :: CoNLL
w_ = ([String] -> [String]) -> CoNLL -> CoNLL
forall a b. (a -> b) -> [a] -> [b]
map (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"_")  CoNLL
ww
                      in
                       [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ CoNLL -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat CoNLL
w_

showRels :: [(a, t String)] -> [(a, [a])] -> String
showRels [(a, t String)]
inds2 [] = []
showRels [(a, t String)]
inds2 ((a
ind,[a]
is):[(a, [a])]
rest) =
                       let lOffs :: [(a, (Int, Int))]
lOffs = [(a, t String)] -> Int -> [(a, (Int, Int))]
forall (t :: * -> *) a.
Foldable t =>
[(a, t String)] -> Int -> [(a, (Int, Int))]
computeOffset [(a, t String)]
inds2 Int
0
                           ltemp :: [(a, (Int, Int))]
ltemp = [(a
i,a -> [(a, (Int, Int))] -> (Int, Int)
forall a b. Eq a => a -> [(a, b)] -> b
getOffsetIndex a
i [(a, (Int, Int))]
lOffs) | a
i <- [a]
is]
                           lcurr :: [String]
lcurr = CoNLL -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (CoNLL -> [String]) -> CoNLL -> [String]
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> [String]) -> [(Int, Int)] -> CoNLL
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
offset,Int
ncomp) -> [a -> String
forall a. Show a => a -> String
show a
ind String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (-Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ii)  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "| Int
ii <- [Int
1..Int
ncomp]]) (((a, (Int, Int)) -> (Int, Int))
-> [(a, (Int, Int))] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (a, (Int, Int)) -> (Int, Int)
forall a b. (a, b) -> b
snd [(a, (Int, Int))]
ltemp)
                           lrest :: String
lrest = [(a, t String)] -> [(a, [a])] -> String
showRels [(a, t String)]
inds2 [(a, [a])]
rest
                            in
                             ([String] -> String
unwords [String]
lcurr) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lrest







getOffsetIndex :: a -> [(a, b)] -> b
getOffsetIndex a
i [(a, b)]
lst = let ll :: [(a, b)]
ll = ((a, b) -> Bool) -> [(a, b)] -> [(a, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(a
x,b
_) -> a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
i) [(a, b)]
lst
                           in
                           (a, b) -> b
forall a b. (a, b) -> b
snd ((a, b) -> b) -> (a, b) -> b
forall a b. (a -> b) -> a -> b
$ [(a, b)] -> (a, b)
forall a. [a] -> a
head [(a, b)]
ll

computeOffset :: [(a, t String)] -> Int -> [(a, (Int, Int))]
computeOffset [] Int
transp = []
computeOffset ((a
i,t String
l):[(a, t String)]
rest) Int
transp = let nw :: Int
nw = ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([String] -> Int) -> [String] -> Int
forall a b. (a -> b) -> a -> b
$ String -> [String]
words (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ t String -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t String
l)
                                     in (a
i,(Int
transp,Int
nw)) (a, (Int, Int)) -> [(a, (Int, Int))] -> [(a, (Int, Int))]
forall a. a -> [a] -> [a]
: ([(a, t String)] -> Int -> [(a, (Int, Int))]
computeOffset [(a, t String)]
rest (Int
transp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nw))



-- alignment in the Graphviz format from the intermediate structure
-- same effect as the old direct function
graphvizAlignment :: PGF -> [Language] -> Expr -> String
graphvizAlignment :: PGF -> [CId] -> Tree -> String
graphvizAlignment PGF
pgf [CId]
langs Tree
exp =
    Doc -> String
render (String -> Doc
text String
"digraph {" Doc -> Doc -> Doc
$$
      Doc
space Doc -> Doc -> Doc
$$
      Int -> Doc -> Doc
nest Int
2 (String -> Doc
text String
"rankdir=LR ;" Doc -> Doc -> Doc
$$
              String -> Doc
text String
"node [shape = record] ;" Doc -> Doc -> Doc
$$
              Doc
space Doc -> Doc -> Doc
$$
              Integer -> [LangSeq] -> [[Rel]] -> Doc
forall a. (Show a, Num a) => a -> [LangSeq] -> [[Rel]] -> Doc
renderList Integer
0 [LangSeq]
lrels [[Rel]]
rrels) Doc -> Doc -> Doc
$$
      String -> Doc
text String
"}")
  where
     (PreAlign [LangSeq]
lrels [[Rel]]
rrels) = PGF -> [CId] -> Tree -> PreAlign
genPreAlignment PGF
pgf [CId]
langs Tree
exp


     renderList :: a -> [LangSeq] -> [[Rel]] -> Doc
renderList a
ii (LangSeq
l:[LangSeq]
ls) ([Rel]
r:[[Rel]]
rs) = a -> Doc
forall a. Show a => a -> Doc
struct a
ii Doc -> Doc -> Doc
<> String -> Doc
text String
"[label = \"" Doc -> Doc -> Doc
<> LangSeq -> Doc
fields LangSeq
l Doc -> Doc -> Doc
<> String -> Doc
text String
"\"] ;" Doc -> Doc -> Doc
$$
                                 (case [LangSeq]
ls of
                                       [] -> Doc
empty
                                       [LangSeq]
_  -> [Doc] -> Doc
vcat [a -> Doc
forall a. Show a => a -> Doc
struct a
ii  Doc -> Doc -> Doc
<> Doc
colon Doc -> Doc -> Doc
<> Int -> Doc
tag Int
id0
                                               Doc -> Doc -> Doc
<> Doc
colon Doc -> Doc -> Doc
<> Char -> Doc
char Char
'e' Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> a -> Doc
forall a. Show a => a -> Doc
struct (a
iia -> a -> a
forall a. Num a => a -> a -> a
+a
1)
                                               Doc -> Doc -> Doc
<> Doc
colon Doc -> Doc -> Doc
<> Int -> Doc
tag Int
id1 Doc -> Doc -> Doc
<> Doc
colon Doc -> Doc -> Doc
<> Char -> Doc
char Char
'w' Doc -> Doc -> Doc
<+> Doc
semi
                                                   | (Int
id0,[Int]
ids) <- [Rel]
r, Int
id1 <- [Int]
ids] Doc -> Doc -> Doc
$$ a -> [LangSeq] -> [[Rel]] -> Doc
renderList (a
ii a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) [LangSeq]
ls [[Rel]]
rs)
     renderList a
ii [] [[Rel]]
_ = Doc
empty
     renderList a
ii [LangSeq
l] [] = a -> Doc
forall a. Show a => a -> Doc
struct a
ii Doc -> Doc -> Doc
<> String -> Doc
text String
"[label = \"" Doc -> Doc -> Doc
<> LangSeq -> Doc
fields LangSeq
l Doc -> Doc -> Doc
<> String -> Doc
text String
"\"] ;"

     fields :: LangSeq -> Doc
fields LangSeq
cs = [Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (Char -> Doc
char Char
'|') [Doc -> Doc
tbrackets (Int -> Doc
tag Int
id) Doc -> Doc -> Doc
<> String -> Doc
text (Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:String
w) | (Int
id,[String]
ws) <- LangSeq
cs, String
w <- [String]
ws])



-- auxiliaries for graphviz syntax
struct :: a -> Doc
struct a
l = String -> Doc
text (String
"struct" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
l)
tbrackets :: Doc -> Doc
tbrackets Doc
d = Char -> Doc
char Char
'<' Doc -> Doc -> Doc
<> Doc
d  Doc -> Doc -> Doc
<> Char -> Doc
char Char
'>'
tag :: Int -> Doc
tag Int
i
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0     = Char -> Doc
char Char
'r' Doc -> Doc -> Doc
<> Int -> Doc
int (Int -> Int
forall a. Num a => a -> a
negate Int
i)
  | Bool
otherwise = Char -> Doc
char Char
'n' Doc -> Doc -> Doc
<> Int -> Doc
int Int
i


---------------------- should be a separate module?

-- visualization with latex output. AR Nov 2015

conlls2latexDoc :: [String] -> String
conlls2latexDoc :: [String] -> String
conlls2latexDoc =
  Doc -> String
render (Doc -> String) -> ([String] -> Doc) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Doc -> Doc
latexDoc (Doc -> Doc) -> ([String] -> Doc) -> [String] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  [Doc] -> Doc
vcat ([Doc] -> Doc) -> ([String] -> [Doc]) -> [String] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (String -> Doc
text String
"" Doc -> Doc -> Doc
$+$ String -> Doc -> Doc
app String
"vspace" (String -> Doc
text String
"4mm")) ([Doc] -> [Doc]) -> ([String] -> [Doc]) -> [String] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
conll2latex ([String] -> [Doc]) -> ([String] -> [String]) -> [String] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)

conll2latex :: String -> Doc
conll2latex :: String -> Doc
conll2latex = [LaTeX] -> Doc
ppLaTeX ([LaTeX] -> Doc) -> (String -> [LaTeX]) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoNLL -> [LaTeX]
conll2latex' (CoNLL -> [LaTeX]) -> (String -> CoNLL) -> String -> [LaTeX]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CoNLL
parseCoNLL

conll2latex' :: CoNLL -> [LaTeX]
conll2latex' :: CoNLL -> [LaTeX]
conll2latex' = Dep -> [LaTeX]
dep2latex (Dep -> [LaTeX]) -> (CoNLL -> Dep) -> CoNLL -> [LaTeX]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoNLL -> Dep
conll2dep'

data Dep = Dep {
    Dep -> Int -> Double
wordLength  :: Int -> Double        -- length of word at position int       -- was: fixed width, millimetres (>= 20.0)
  , Dep -> [(String, (String, String))]
tokens      :: [(String,(String,String))]    -- word, (pos,features) (0..)
  , Dep -> [((Int, Int), String)]
deps        :: [((Int,Int),String)] -- from, to, label
  , Dep -> Int
root        :: Int                  -- root word position
  }

-- some general measures
defaultWordLength :: Double
defaultWordLength = Double
20.0  -- the default fixed width word length, making word 100 units
defaultUnit :: Double
defaultUnit       = Double
0.2   -- unit in latex pictures, 0.2 millimetres
spaceLength :: Double
spaceLength       = Double
10.0
charWidth :: Double
charWidth = Double
1.8

wsize :: (t -> Double) -> t -> Double
wsize t -> Double
rwld  t
w  = Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* t -> Double
rwld t
w Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
spaceLength                   -- word length, units
wpos :: (t -> Double) -> t -> Double
wpos t -> Double
rwld t
i    = [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [(t -> Double) -> t -> Double
forall t. (t -> Double) -> t -> Double
wsize t -> Double
rwld t
j | t
j <- [t
0..t
it -> t -> t
forall a. Num a => a -> a -> a
-t
1]]           -- start position of the i'th word
wdist :: (t -> Double) -> t -> t -> Double
wdist t -> Double
rwld t
x t
y = [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [(t -> Double) -> t -> Double
forall t. (t -> Double) -> t -> Double
wsize t -> Double
rwld t
i | t
i <- [t -> t -> t
forall a. Ord a => a -> a -> a
min t
x t
y .. t -> t -> t
forall a. Ord a => a -> a -> a
max t
x t
y t -> t -> t
forall a. Num a => a -> a -> a
- t
1]]    -- distance between words x and y
labelheight :: Double -> Double
labelheight Double
h  = Double
h Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
arcbase Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
3    -- label just above arc; 25 would put it just below
labelstart :: a -> a
labelstart a
c   = a
c a -> a -> a
forall a. Num a => a -> a -> a
- a
15.0           -- label starts 15u left of arc centre
arcbase :: Double
arcbase        = Double
30.0               -- arcs start and end 40u above the bottom
arcfactor :: a -> a
arcfactor a
r    = a
r a -> a -> a
forall a. Num a => a -> a -> a
* a
600            -- reduction of arc size from word distance
xyratio :: Double
xyratio        = Double
3                  -- width/height ratio of arcs

putArc :: (Int -> Double) -> Int -> Int -> Int -> String -> [DrawingCommand]
putArc :: (Int -> Double) -> Int -> Int -> Int -> String -> [DrawingCommand]
putArc Int -> Double
frwld Int
height Int
x Int
y String
label = [DrawingCommand
oval,DrawingCommand
arrowhead,DrawingCommand
labelling] where
  oval :: DrawingCommand
oval = Position -> Object -> DrawingCommand
Put (Double
ctr,Double
arcbase) (Position -> Object
OvalTop (Double
wdth,Double
hght))
  arrowhead :: DrawingCommand
arrowhead = Position -> Object -> DrawingCommand
Put (Double
endp,Double
arcbase Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
5) (Double -> Object
ArrowDown Double
5)   -- downgoing arrow 5u above the arc base
  labelling :: DrawingCommand
labelling = Position -> Object -> DrawingCommand
Put (Double -> Double
forall a. Fractional a => a -> a
labelstart Double
ctr,Double -> Double
labelheight (Double
hghtDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)) (String -> Object
TinyText String
label)
  dxy :: Double
dxy  = (Int -> Double) -> Int -> Int -> Double
forall t.
(Ord t, Num t, Enum t) =>
(t -> Double) -> t -> t -> Double
wdist Int -> Double
frwld Int
x Int
y             -- distance between words, >>= 20.0
  ndxy :: Double
ndxy = Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
rwld Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height  -- distance that is indep of word length
  hdxy :: Double
hdxy = Double
dxy Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2                     -- half the distance
  wdth :: Double
wdth = Double
dxy Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double -> Double
forall a. Num a => a -> a
arcfactor Double
rwld)Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
dxy  -- longer arcs are wider in proportion
  hght :: Double
hght = Double
ndxy Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
xyratio Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
rwld)      -- arc height is independent of word length
  begp :: Int
begp = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
x Int
y                     -- begin position of oval
  ctr :: Double
ctr  = (Int -> Double) -> Int -> Double
forall t. (Num t, Enum t) => (t -> Double) -> t -> Double
wpos Int -> Double
frwld Int
begp Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
hdxy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (if Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
y then Double
20 else  Double
10)  -- LR arcs are farther right from center of oval
  endp :: Double
endp = (if Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
y then Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) else (-)) Double
ctr (Double
wdthDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)            -- the point of the arrow
  rwld :: Double
rwld = Double
0.5 ----

dep2latex :: Dep -> [LaTeX]
dep2latex :: Dep -> [LaTeX]
dep2latex Dep
d =
  [String -> LaTeX
Comment ([String] -> String
unwords (((String, (String, String)) -> String)
-> [(String, (String, String))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, (String, String)) -> String
forall a b. (a, b) -> a
fst (Dep -> [(String, (String, String))]
tokens Dep
d))),
   Double -> Position -> [DrawingCommand] -> LaTeX
Picture Double
defaultUnit (Double
width,Double
height) (
     [Position -> Object -> DrawingCommand
Put ((Int -> Double) -> Int -> Double
forall t. (Num t, Enum t) => (t -> Double) -> t -> Double
wpos Int -> Double
rwld Int
i,Double
0) (String -> Object
Text String
w) | (Int
i,String
w) <- [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (((String, (String, String)) -> String)
-> [(String, (String, String))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, (String, String)) -> String
forall a b. (a, b) -> a
fst (Dep -> [(String, (String, String))]
tokens Dep
d))]   -- words
  [DrawingCommand] -> [DrawingCommand] -> [DrawingCommand]
forall a. [a] -> [a] -> [a]
++ [Position -> Object -> DrawingCommand
Put ((Int -> Double) -> Int -> Double
forall t. (Num t, Enum t) => (t -> Double) -> t -> Double
wpos Int -> Double
rwld Int
i,Double
15) (String -> Object
TinyText String
w) | (Int
i,(String
w,String
_)) <- [Int] -> [(String, String)] -> [(Int, (String, String))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (((String, (String, String)) -> (String, String))
-> [(String, (String, String))] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (String, (String, String)) -> (String, String)
forall a b. (a, b) -> b
snd (Dep -> [(String, (String, String))]
tokens Dep
d))]   -- pos tags 15u above bottom
---  ++ [Put (wpos rwld i,-15) (TinyText w) | (i,(_,w)) <- zip [0..] (map snd (tokens d))]   -- features 15u below bottom -> DON'T SHOW
  [DrawingCommand] -> [DrawingCommand] -> [DrawingCommand]
forall a. [a] -> [a] -> [a]
++ [[DrawingCommand]] -> [DrawingCommand]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [(Int -> Double) -> Int -> Int -> Int -> String -> [DrawingCommand]
putArc Int -> Double
rwld (Int -> Int -> Int
forall a. (Num a, Ord a) => Int -> Int -> a
aheight Int
x Int
y) Int
x Int
y String
label | ((Int
x,Int
y),String
label) <- Dep -> [((Int, Int), String)]
deps Dep
d]    -- arcs and labels
  [DrawingCommand] -> [DrawingCommand] -> [DrawingCommand]
forall a. [a] -> [a] -> [a]
++ [Position -> Object -> DrawingCommand
Put ((Int -> Double) -> Int -> Double
forall t. (Num t, Enum t) => (t -> Double) -> t -> Double
wpos Int -> Double
rwld (Dep -> Int
root Dep
d) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
15,Double
height) (Double -> Object
ArrowDown (Double
heightDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
arcbase))]
  [DrawingCommand] -> [DrawingCommand] -> [DrawingCommand]
forall a. [a] -> [a] -> [a]
++ [Position -> Object -> DrawingCommand
Put ((Int -> Double) -> Int -> Double
forall t. (Num t, Enum t) => (t -> Double) -> t -> Double
wpos Int -> Double
rwld (Dep -> Int
root Dep
d) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
20,Double
height Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
10) (String -> Object
TinyText String
"root")]
  )]
 where
   wld :: Int -> Double
wld Int
i  = Dep -> Int -> Double
wordLength Dep
d Int
i  -- >= 20.0
   rwld :: Int -> Double
rwld Int
i = (Int -> Double
wld Int
i) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
defaultWordLength       -- >= 1.0
   aheight :: Int -> Int -> a
aheight Int
x Int
y = Int -> Int -> a
forall a. (Num a, Ord a) => Int -> Int -> a
depth (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
x Int
y) (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
x Int
y) a -> a -> a
forall a. Num a => a -> a -> a
+ a
1    ---- abs (x-y)
   arcs :: [(Int, Int)]
arcs = [(Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
u Int
v, Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
u Int
v) | ((Int
u,Int
v),String
_) <- Dep -> [((Int, Int), String)]
deps Dep
d]
   depth :: Int -> Int -> p
depth Int
x Int
y = case [(Int
u,Int
v) | (Int
u,Int
v) <- [(Int, Int)]
arcs, (Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
u Bool -> Bool -> Bool
&& Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
y) Bool -> Bool -> Bool
|| (Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
u Bool -> Bool -> Bool
&& Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
y)] of ---- only projective arcs counted
     [] -> p
0
     [(Int, Int)]
uvs -> p
1 p -> p -> p
forall a. Num a => a -> a -> a
+ [p] -> p
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (p
0p -> [p] -> [p]
forall a. a -> [a] -> [a]
:[Int -> Int -> p
depth Int
u Int
v | (Int
u,Int
v) <- [(Int, Int)]
uvs])
   width :: Double
width = {-round-} ([Double] -> Double
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [(Int -> Double) -> Int -> Double
forall t. (t -> Double) -> t -> Double
wsize Int -> Double
rwld Int
w | (Int
w,(String, (String, String))
_) <- [Int]
-> [(String, (String, String))]
-> [(Int, (String, (String, String)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (Dep -> [(String, (String, String))]
tokens Dep
d)]) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ {-round-} Double
spaceLength Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (([(String, (String, String))] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Dep -> [(String, (String, String))]
tokens Dep
d)) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
   height :: Double
height = Double
50 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
20 Double -> Double -> Double
forall a. Num a => a -> a -> a
* {-round-} ([Double] -> Double
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Double
0Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
:[Int -> Int -> Double
forall a. (Num a, Ord a) => Int -> Int -> a
aheight Int
x Int
y | ((Int
x,Int
y),String
_) <- Dep -> [((Int, Int), String)]
deps Dep
d]))

type CoNLL = [[String]]
parseCoNLL :: String -> CoNLL
parseCoNLL :: String -> CoNLL
parseCoNLL = (String -> [String]) -> [String] -> CoNLL
forall a b. (a -> b) -> [a] -> [b]
map String -> [String]
words ([String] -> CoNLL) -> (String -> [String]) -> String -> CoNLL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

--conll2dep :: String -> Dep
--conll2dep = conll2dep' . parseCoNLL

conll2dep' :: CoNLL -> Dep
conll2dep' :: CoNLL -> Dep
conll2dep' CoNLL
ls = Dep :: (Int -> Double)
-> [(String, (String, String))]
-> [((Int, Int), String)]
-> Int
-> Dep
Dep {
    wordLength :: Int -> Double
wordLength = Int -> Double
wld 
  , tokens :: [(String, (String, String))]
tokens = [(String, (String, String))]
toks
  , deps :: [((Int, Int), String)]
deps = [((Int, Int), String)]
dps
  , root :: Int
root = [Int] -> Int
forall a. [a] -> a
head ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ [String -> Int
forall a. Read a => String -> a
read String
xInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1 | String
x:String
_:String
_:String
_:String
_:String
_:String
"0":[String]
_ <- CoNLL
ls] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
1]
  }
 where
   wld :: Int -> Double
wld Int
i = [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Double
0Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
:[Double
charWidth Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
w) | String
w <- let (String
tok,(String
pos,String
feat)) = [(String, (String, String))]
toks [(String, (String, String))] -> Int -> (String, (String, String))
forall a. [a] -> Int -> a
!! Int
i in [String
tok,String
pos {-,feat-}]]) --- feat not shown
   toks :: [(String, (String, String))]
toks = [(String
w,(String
c,String
m)) | String
_:String
w:String
_:String
c:String
_:String
m:[String]
_ <- CoNLL
ls]
   dps :: [((Int, Int), String)]
dps = [((String -> Int
forall a. Read a => String -> a
read String
yInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1, String -> Int
forall a. Read a => String -> a
read String
xInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1),String
lab) | String
x:String
_:String
_:String
_:String
_:String
_:String
y:String
lab:[String]
_ <- CoNLL
ls, String
y String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=String
"0"]
   --maxdist = maximum [abs (x-y) | ((x,y),_) <- dps]


-- * LaTeX Pictures (see https://en.wikibooks.org/wiki/LaTeX/Picture)

-- We render both LaTeX and SVG from this intermediate representation of
-- LaTeX pictures.

data LaTeX = Comment String | Picture UnitLengthMM Size [DrawingCommand]
data DrawingCommand = Put Position Object
data Object = Text String | TinyText String | OvalTop Size | ArrowDown Length

type UnitLengthMM = Double
type Size = (Double,Double)
type Position = (Double,Double)
type Length = Double


-- * latex formatting
ppLaTeX :: [LaTeX] -> Doc
ppLaTeX = [Doc] -> Doc
vcat ([Doc] -> Doc) -> ([LaTeX] -> [Doc]) -> [LaTeX] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LaTeX -> Doc) -> [LaTeX] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map LaTeX -> Doc
ppLaTeX1
  where
    ppLaTeX1 :: LaTeX -> Doc
ppLaTeX1 LaTeX
el =
      case LaTeX
el of
        Comment String
s -> String -> Doc
comment String
s
        Picture Double
unit Position
size [DrawingCommand]
cmds ->
          String -> Doc -> Doc
app String
"setlength{\\unitlength}" (String -> Doc
text (Double -> String
forall a. Show a => a -> String
show Double
unit String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"mm"))
          Doc -> Doc -> Doc
$$ Doc -> Int -> Doc -> Doc
hang (String -> Doc -> Doc
app String
"begin" (String -> Doc
text String
"picture")Doc -> Doc -> Doc
<>String -> Doc
text (Position -> String
forall a. Show a => a -> String
show Position
size)) Int
2
                  ([Doc] -> Doc
vcat ((DrawingCommand -> Doc) -> [DrawingCommand] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map DrawingCommand -> Doc
ppDrawingCommand [DrawingCommand]
cmds))
          Doc -> Doc -> Doc
$$ String -> Doc -> Doc
app String
"end" (String -> Doc
text String
"picture")
          Doc -> Doc -> Doc
$$ String -> Doc
text String
""

    ppDrawingCommand :: DrawingCommand -> Doc
ppDrawingCommand (Put Position
pos Object
obj) = Position -> Doc -> Doc
forall a b. (Show a, Show b) => (a, b) -> Doc -> Doc
put Position
pos (Object -> Doc
ppObject Object
obj)

    ppObject :: Object -> Doc
ppObject Object
obj =
      case Object
obj of
        Text String
s -> String -> Doc
text String
s
        TinyText String
s -> Doc -> Doc
small (String -> Doc
text String
s)
        OvalTop Position
size -> String -> Doc
text String
"\\oval" Doc -> Doc -> Doc
<> String -> Doc
text (Position -> String
forall a. Show a => a -> String
show Position
size) Doc -> Doc -> Doc
<> String -> Doc
text String
"[t]"
        ArrowDown Double
len -> String -> Doc -> Doc
app String
"vector(0,-1)" (String -> Doc
text (Double -> String
forall a. Show a => a -> String
show Double
len))

    put :: (a, b) -> Doc -> Doc
put p :: (a, b)
p@(a
_,b
_) = String -> Doc -> Doc
app (String
"put" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (a, b) -> String
forall a. Show a => a -> String
show (a, b)
p)
    small :: Doc -> Doc
small Doc
w = String -> Doc
text String
"{\\tiny" Doc -> Doc -> Doc
<+> Doc
w Doc -> Doc -> Doc
<> String -> Doc
text String
"}"
    comment :: String -> Doc
comment String
s = String -> Doc
text String
"%%" Doc -> Doc -> Doc
<+> String -> Doc
text String
s -- line break show follow
    
app :: String -> Doc -> Doc
app String
macro Doc
arg = String -> Doc
text String
"\\" Doc -> Doc -> Doc
<> String -> Doc
text String
macro Doc -> Doc -> Doc
<> String -> Doc
text String
"{" Doc -> Doc -> Doc
<> Doc
arg Doc -> Doc -> Doc
<> String -> Doc
text String
"}"


latexDoc :: Doc -> Doc
latexDoc :: Doc -> Doc
latexDoc Doc
body =
  [Doc] -> Doc
vcat [String -> Doc
text String
"\\documentclass{article}",
        String -> Doc
text String
"\\usepackage[utf8]{inputenc}",
        String -> Doc
text String
"\\begin{document}",
        Doc
body,
        String -> Doc
text String
"\\end{document}"]

-- * SVG (see https://www.w3.org/Graphics/SVG/IG/resources/svgprimer.html)

-- | Render LaTeX pictures as SVG
toSVG :: [LaTeX] -> [SVG]
toSVG = (LaTeX -> [SVG]) -> [LaTeX] -> [SVG]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LaTeX -> [SVG]
toSVG1
  where
    toSVG1 :: LaTeX -> [SVG]
toSVG1 LaTeX
el =
      case LaTeX
el of
        Comment String
s -> []
        Picture Double
unit size :: Position
size@(Double
w,Double
h) [DrawingCommand]
cmds ->
          [String -> [(String, String)] -> [SVG] -> SVG
Elem String
"svg" [String
"width"String -> Integer -> (String, String)
forall a a. Show a => a -> a -> (a, String)
.=Integer
x1,String
"height"String -> Integer -> (String, String)
forall a a. Show a => a -> a -> (a, String)
.=Integer
y0Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
5,
                       (String
"viewBox",[String] -> String
unwords ((Integer -> String) -> [Integer] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> String
forall a. Show a => a -> String
show [Integer
0,Integer
0,Integer
x1,Integer
y0Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
5])),
                       (String
"version",String
"1.1"),
                       (String
"xmlns",String
"http://www.w3.org/2000/svg")]
                       (SVG
white_bgSVG -> [SVG] -> [SVG]
forall a. a -> [a] -> [a]
:(DrawingCommand -> [SVG]) -> [DrawingCommand] -> [SVG]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DrawingCommand -> [SVG]
draw [DrawingCommand]
cmds)]
          where
            white_bg :: SVG
white_bg =
              String -> [(String, String)] -> [SVG] -> SVG
Elem String
"rect" [String
"x"String -> Integer -> (String, String)
forall a a. Show a => a -> a -> (a, String)
.=Integer
0,String
"y"String -> Integer -> (String, String)
forall a a. Show a => a -> a -> (a, String)
.=Integer
0,String
"width"String -> Integer -> (String, String)
forall a a. Show a => a -> a -> (a, String)
.=Integer
x1,String
"height"String -> Integer -> (String, String)
forall a a. Show a => a -> a -> (a, String)
.=Integer
y0Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
5,
                           (String
"fill",String
"white")] []

            draw :: DrawingCommand -> [SVG]
draw (Put Position
pos Object
obj) = Position -> Object -> [SVG]
objectSVG Position
pos Object
obj

            objectSVG :: Position -> Object -> [SVG]
objectSVG Position
pos Object
obj =
              case Object
obj of
                Text String
s -> [Integer -> Position -> String -> SVG
forall a. Show a => a -> Position -> String -> SVG
text Integer
16 Position
pos String
s]
                TinyText String
s -> [Integer -> Position -> String -> SVG
forall a. Show a => a -> Position -> String -> SVG
text Integer
10 Position
pos String
s]
                OvalTop Position
size -> [Position -> Position -> SVG
ovalTop Position
pos Position
size]
                ArrowDown Double
len -> Position -> Double -> [SVG]
arrowDown Position
pos Double
len

            text :: a -> Position -> String -> SVG
text a
h (Double
x,Double
y) String
s =
              String -> [(String, String)] -> [SVG] -> SVG
Elem String
"text" [String
"x"String -> Integer -> (String, String)
forall a a. Show a => a -> a -> (a, String)
.=Double -> Integer
forall a. Integral a => Double -> a
xc Double
x,String
"y"String -> Integer -> (String, String)
forall a a. Show a => a -> a -> (a, String)
.=Double -> Integer
yc Double
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
2,String
"font-size"String -> a -> (String, String)
forall a a. Show a => a -> a -> (a, String)
.=a
h]
                          [String -> SVG
CharData String
s]

            ovalTop :: Position -> Position -> SVG
ovalTop (Double
x,Double
y) (Double
w,Double
h) =
              String -> [(String, String)] -> [SVG] -> SVG
Elem String
"path" [(String
"d",String
path),(String
"stroke",String
"black"),(String
"fill",String
"none")] []
              where
                x1 :: Double
x1 = Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
wDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2
                x2 :: Double
x2 = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
x (Double
x1Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
r)
                x3 :: Double
x3 = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
x (Double
x4Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
r)
                x4 :: Double
x4 = Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
wDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2
                y1 :: Double
y1 = Double
y
                y2 :: Double
y2 = Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
r
                r :: Double
r = Double
hDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2
                sx :: Double -> String
sx = Integer -> String
forall a. Show a => a -> String
show (Integer -> String) -> (Double -> Integer) -> Double -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Integer
forall a. Integral a => Double -> a
xc
                sy :: Double -> String
sy = Integer -> String
forall a. Show a => a -> String
show (Integer -> String) -> (Double -> Integer) -> Double -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Integer
yc
                path :: String
path = [String] -> String
unwords ([String
"M",Double -> String
sx Double
x1,Double -> String
sy Double
y1,String
"Q",Double -> String
sx Double
x1,Double -> String
sy Double
y2,Double -> String
sx Double
x2,Double -> String
sy Double
y2,
                                 String
"L",Double -> String
sx Double
x3,Double -> String
sy Double
y2,String
"Q",Double -> String
sx Double
x4,Double -> String
sy Double
y2,Double -> String
sx Double
x4,Double -> String
sy Double
y1])

            arrowDown :: Position -> Double -> [SVG]
arrowDown (Double
x,Double
y) Double
len =
                [String -> [(String, String)] -> [SVG] -> SVG
Elem String
"line" [String
"x1"String -> Integer -> (String, String)
forall a a. Show a => a -> a -> (a, String)
.=Double -> Integer
forall a. Integral a => Double -> a
xc Double
x,String
"y1"String -> Integer -> (String, String)
forall a a. Show a => a -> a -> (a, String)
.=Double -> Integer
yc Double
y,String
"x2"String -> Integer -> (String, String)
forall a a. Show a => a -> a -> (a, String)
.=Double -> Integer
forall a. Integral a => Double -> a
xc Double
x,String
"y2"String -> Integer -> (String, String)
forall a a. Show a => a -> a -> (a, String)
.=Integer
y2,
                              (String
"stroke",String
"black")] [],
                 String -> [(String, String)] -> [SVG] -> SVG
Elem String
"path" [(String
"d",[String] -> String
unwords [String]
arrowhead)] []]
               where
                 x2 :: Integer
x2 = Double -> Integer
forall a. Integral a => Double -> a
xc Double
x
                 y2 :: Integer
y2 = Double -> Integer
yc (Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
len)
                 arrowhead :: [String]
arrowhead = String
"M"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:(Integer -> String) -> [Integer] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> String
forall a. Show a => a -> String
show [Integer
x2,Integer
y2,Integer
x2Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
3,Integer
y2Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
6,Integer
x2Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
3,Integer
y2Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
6]

            xc :: Double -> a
xc Double
x = Double -> a
forall a. Integral a => Double -> a
num Double
xa -> a -> a
forall a. Num a => a -> a -> a
+a
5
            yc :: Double -> Integer
yc Double
y = Integer
y0Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Double -> Integer
forall a. Integral a => Double -> a
num Double
y
            x1 :: Integer
x1 = Double -> Integer
forall a. Integral a => Double -> a
num Double
wInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
10
            y0 :: Integer
y0 = Double -> Integer
forall a. Integral a => Double -> a
num Double
hInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
20
            num :: Double -> b
num Double
x = Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
scaleDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
x)
            scale :: Double
scale = Double
unitDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
5

            infix 0 .=
            a
n.= :: a -> a -> (a, String)
.=a
v = (a
n,a -> String
forall a. Show a => a -> String
show a
v)

-- * SVG is XML

data SVG = CharData String | Elem TagName Attrs [SVG]
type TagName = String
type Attrs = [(String,String)]

ppSVG :: [SVG] -> Doc
ppSVG [SVG]
svg =
  [Doc] -> Doc
vcat [String -> Doc
text String
"<?xml version=\"1.0\" standalone=\"no\"?>",
        String -> Doc
text String
"<!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\"",
        String -> Doc
text String
"\"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\">",
        String -> Doc
text String
"",
        [Doc] -> Doc
vcat ((SVG -> Doc) -> [SVG] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map SVG -> Doc
ppSVG1 [SVG]
svg)] -- It should be a single <svg> element...
  where
    ppSVG1 :: SVG -> Doc
ppSVG1 SVG
svg1 =
      case SVG
svg1 of
        CharData String
s -> String -> Doc
text (String -> String
forall (t :: * -> *). Foldable t => t Char -> String
encode String
s)
        Elem String
tag [(String, String)]
attrs [] ->
            String -> Doc
text String
"<"Doc -> Doc -> Doc
<>String -> Doc
text String
tagDoc -> Doc -> Doc
<>[Doc] -> Doc
cat (((String, String) -> Doc) -> [(String, String)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> Doc
forall (t :: * -> *). Foldable t => (String, t Char) -> Doc
attr [(String, String)]
attrs) Doc -> Doc -> Doc
<> String -> Doc
text String
"/>"
        Elem String
tag [(String, String)]
attrs [SVG]
svg ->
            [Doc] -> Doc
cat [String -> Doc
text String
"<"Doc -> Doc -> Doc
<>String -> Doc
text String
tagDoc -> Doc -> Doc
<>[Doc] -> Doc
cat (((String, String) -> Doc) -> [(String, String)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> Doc
forall (t :: * -> *). Foldable t => (String, t Char) -> Doc
attr [(String, String)]
attrs) Doc -> Doc -> Doc
<> String -> Doc
text String
">",
                 Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
cat ((SVG -> Doc) -> [SVG] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map SVG -> Doc
ppSVG1 [SVG]
svg)),
                 String -> Doc
text String
"</"Doc -> Doc -> Doc
<>String -> Doc
text String
tagDoc -> Doc -> Doc
<>String -> Doc
text String
">"]

    attr :: (String, t Char) -> Doc
attr (String
n,t Char
v) = String -> Doc
text String
" "Doc -> Doc -> Doc
<>String -> Doc
text String
nDoc -> Doc -> Doc
<>String -> Doc
text String
"=\""Doc -> Doc -> Doc
<>String -> Doc
text (t Char -> String
forall (t :: * -> *). Foldable t => t Char -> String
encode t Char
v)Doc -> Doc -> Doc
<>String -> Doc
text String
"\""

    encode :: t Char -> String
encode t Char
s = (Char -> String -> String) -> String -> t Char -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> String -> String
encodeEntity String
"" t Char
s

    encodeEntity :: Char -> String -> String
encodeEntity = (Any -> Bool) -> Char -> String -> String
forall p. p -> Char -> String -> String
encodeEntity' (Bool -> Any -> Bool
forall a b. a -> b -> a
const Bool
False)
    encodeEntity' :: p -> Char -> String -> String
encodeEntity' p
esc Char
c String
r =
      case Char
c of
        Char
'&' -> String
"&amp;"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
r
        Char
'<' -> String
"&lt;"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
r
        Char
'>' -> String
"&gt;"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
r
        Char
_ -> Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
r


----------------------------------
-- concrete syntax annotations (local) on top of conll
-- examples of annotations:
-- UseComp {"not"} PART neg head 
-- UseComp {*} AUX cop head

type CncLabels = [CncLabel]

data CncLabel =
    CncSyncat (String, String -> Maybe (String -> String,String,String))
    -- (fun, word/lemma -> (pos,label,target))
    -- the pos can remain unchanged, as in the current notation in the article
  | CncMorpho (String,[String])
    -- (category, features in ascending order)
  | CncForm (String,(String,String))
    -- (wordform, (lemma,features))

fixCoNLL :: CncLabels -> CoNLL -> CoNLL
fixCoNLL :: CncLabels -> CoNLL -> CoNLL
fixCoNLL CncLabels
cncLabels CoNLL
conll = ([String] -> [String]) -> CoNLL -> CoNLL
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> [String]
fixMorpho ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
fixDep) (CoNLL -> CoNLL
markRoot CoNLL
conll) where
  labels :: [(String, String -> Maybe (String -> String, String, String))]
labels  = [(String, String -> Maybe (String -> String, String, String))
l | CncSyncat (String, String -> Maybe (String -> String, String, String))
l <- CncLabels
cncLabels]
  flabels :: [(String, [String])]
flabels = [(String, [String])
r | CncMorpho (String, [String])
r <- CncLabels
cncLabels]

-- change the root label from dep to root
--- doing this for the leftmost word of the root node
  markRoot :: CoNLL -> CoNLL
markRoot CoNLL
rows = case CoNLL
rows of
    (String
i:String
word:String
fun:String
pos:String
cat:String
x_:String
"0":String
lab_:[String]
xs):CoNLL
rs -> (String
iString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
wordString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
funString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
posString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
catString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
x_String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
"0"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
"root"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
xs) [String] -> CoNLL -> CoNLL
forall a. a -> [a] -> [a]
: ([String] -> [String]) -> CoNLL -> CoNLL
forall a b. (a -> b) -> [a] -> [b]
map (String -> [String] -> [String]
markNoRoot String
i) CoNLL
rs
    [String]
r:CoNLL
rs -> [String]
r [String] -> CoNLL -> CoNLL
forall a. a -> [a] -> [a]
: CoNLL -> CoNLL
markRoot CoNLL
rs
    CoNLL
_ -> CoNLL
rows --- what about if there is no root?

  markNoRoot :: String -> [String] -> [String]
markNoRoot String
r row :: [String]
row@(String
i:String
word:String
fun:String
pos:String
cat:String
x_:String
j:String
label:[String]
xs) = case String
j of
    String
"0" -> (String
iString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
wordString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
funString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
posString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
catString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
x_String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
r String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
labelString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
xs)
    String
_ -> [String]
row
    
  fixDep :: [String] -> [String]
fixDep [String]
row = case [String]
row of
 
    (String
i:String
word:String
fun:String
pos:String
cat:String
x_:String
j:String
label:[String]
xs) | String
label String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"root" -> case (String, String) -> Maybe (String -> String, String, String)
look (String
fun,String
word) of
      Just (String -> String
pos',String
label',String
"head") -> (String
iString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
wordString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
funString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String -> String
pos' String
posString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
catString -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
x_String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
j              String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
label'String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
xs)
      Just (String -> String
pos',String
label',String
target) -> (String
iString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
wordString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
funString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String -> String
pos' String
posString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
catString -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
x_String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> String -> String
getDep String
j String
targetString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
label'String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
xs)
      Maybe (String -> String, String, String)
_ ->                         [String]
row
    [String]
_ -> [String]
row
    
  fixMorpho :: [String] -> [String]
fixMorpho (String
i:String
word:String
fun:String
pos:String
cat: String
mo :String
j:String
label:[String]
xs) = (String
iString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
wordString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
funString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
posString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
catString -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String -> String -> String
forall a. Show a => String -> a -> String -> String
feat String
cat String
word String
mo) String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
jString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
labelString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
xs)
    
  look :: (String, String) -> Maybe (String -> String, String, String)
look (String
fun,String
word) = case String
-> [(String, String -> Maybe (String -> String, String, String))]
-> Maybe (String -> Maybe (String -> String, String, String))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
fun [(String, String -> Maybe (String -> String, String, String))]
labels of
    Just String -> Maybe (String -> String, String, String)
relabel -> case String -> Maybe (String -> String, String, String)
relabel String
word of
      Just (String -> String, String, String)
row -> (String -> String, String, String)
-> Maybe (String -> String, String, String)
forall a. a -> Maybe a
Just (String -> String, String, String)
row
      Maybe (String -> String, String, String)
_ -> case String
-> [(String, String -> Maybe (String -> String, String, String))]
-> Maybe (String -> Maybe (String -> String, String, String))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"*" [(String, String -> Maybe (String -> String, String, String))]
labels of
        Just String -> Maybe (String -> String, String, String)
starlabel -> String -> Maybe (String -> String, String, String)
starlabel String
word
        Maybe (String -> Maybe (String -> String, String, String))
_ -> Maybe (String -> String, String, String)
forall a. Maybe a
Nothing
    Maybe (String -> Maybe (String -> String, String, String))
_ -> case String
-> [(String, String -> Maybe (String -> String, String, String))]
-> Maybe (String -> Maybe (String -> String, String, String))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"*" [(String, String -> Maybe (String -> String, String, String))]
labels of
        Just String -> Maybe (String -> String, String, String)
starlabel -> String -> Maybe (String -> String, String, String)
starlabel String
word
        Maybe (String -> Maybe (String -> String, String, String))
_ -> Maybe (String -> String, String, String)
forall a. Maybe a
Nothing
  
  getDep :: String -> String -> String
getDep String
j String
label = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
j String -> String
forall a. a -> a
id (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ (String, String) -> [((String, String), String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String
label,String
j) [((String
label,String
j),String
i) | String
i:String
word:String
fun:String
pos:String
cat:String
x_:String
j:String
label:[String]
xs <- CoNLL
conll]

  feat :: String -> a -> String -> String
feat String
cat a
word String
x = case String -> [(String, [String])] -> Maybe [String]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
cat [(String, [String])]
flabels of
    Just [String]
tags | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
x Bool -> Bool -> Bool
&& [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
tags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> String -> Int
forall a. Read a => String -> a
read String
x -> [String]
tags [String] -> Int -> String
forall a. [a] -> Int -> a
!! String -> Int
forall a. Read a => String -> a
read String
x
    Maybe [String]
_ -> case String -> [(String, [String])] -> Maybe [String]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (a -> String
forall a. Show a => a -> String
show a
word) [(String, [String])]
flabels of
      Just (String
t:[String]
_) -> String
t
      Maybe [String]
_ -> String
cat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x

getCncDepLabels :: String -> CncLabels
getCncDepLabels :: String -> CncLabels
getCncDepLabels String
s = [String] -> CncLabels
wlabels [String]
ws CncLabels -> CncLabels -> CncLabels
forall a. [a] -> [a] -> [a]
++ [String] -> CncLabels
flabels [String]
fs
 where
  wlabels :: [String] -> CncLabels
wlabels =
    ((String, String -> Maybe (String -> String, String, String))
 -> CncLabel)
-> [(String, String -> Maybe (String -> String, String, String))]
-> CncLabels
forall a b. (a -> b) -> [a] -> [b]
map (String, String -> Maybe (String -> String, String, String))
-> CncLabel
CncSyncat ([(String, String -> Maybe (String -> String, String, String))]
 -> CncLabels)
-> ([String]
    -> [(String, String -> Maybe (String -> String, String, String))])
-> [String]
-> CncLabels
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    ([(String, (String, (String -> String, String, String)))]
 -> (String, String -> Maybe (String -> String, String, String)))
-> [[(String, (String, (String -> String, String, String)))]]
-> [(String, String -> Maybe (String -> String, String, String))]
forall a b. (a -> b) -> [a] -> [b]
map [(String, (String, (String -> String, String, String)))]
-> (String, String -> Maybe (String -> String, String, String))
forall a b. [(a, (String, b))] -> (a, String -> Maybe b)
merge ([[(String, (String, (String -> String, String, String)))]]
 -> [(String, String -> Maybe (String -> String, String, String))])
-> ([String]
    -> [[(String, (String, (String -> String, String, String)))]])
-> [String]
-> [(String, String -> Maybe (String -> String, String, String))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    ((String, (String, (String -> String, String, String)))
 -> (String, (String, (String -> String, String, String))) -> Bool)
-> [(String, (String, (String -> String, String, String)))]
-> [[(String, (String, (String -> String, String, String)))]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\ (String
x,(String, (String -> String, String, String))
_) (String
a,(String, (String -> String, String, String))
_) -> String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
a) ([(String, (String, (String -> String, String, String)))]
 -> [[(String, (String, (String -> String, String, String)))]])
-> ([String]
    -> [(String, (String, (String -> String, String, String)))])
-> [String]
-> [[(String, (String, (String -> String, String, String)))]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    ((String, (String, (String -> String, String, String)))
 -> (String, (String, (String -> String, String, String)))
 -> Ordering)
-> [(String, (String, (String -> String, String, String)))]
-> [(String, (String, (String -> String, String, String)))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((String, (String, (String -> String, String, String))) -> String)
-> (String, (String, (String -> String, String, String)))
-> (String, (String, (String -> String, String, String)))
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (String, (String, (String -> String, String, String))) -> String
forall a b. (a, b) -> a
fst) ([(String, (String, (String -> String, String, String)))]
 -> [(String, (String, (String -> String, String, String)))])
-> ([String]
    -> [(String, (String, (String -> String, String, String)))])
-> [String]
-> [(String, (String, (String -> String, String, String)))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (String
 -> [(String, (String, (String -> String, String, String)))])
-> [String]
-> [(String, (String, (String -> String, String, String)))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [(String, (String, (String -> String, String, String)))]
analyse ([String]
 -> [(String, (String, (String -> String, String, String)))])
-> ([String] -> [String])
-> [String]
-> [(String, (String, (String -> String, String, String)))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
forall (t :: * -> *). Foldable t => t Char -> Bool
chooseW
    
  flabels :: [String] -> CncLabels
flabels =
    ((String, [String]) -> CncLabel)
-> [(String, [String])] -> CncLabels
forall a b. (a -> b) -> [a] -> [b]
map (String, [String]) -> CncLabel
CncMorpho ([(String, [String])] -> CncLabels)
-> ([String] -> [(String, [String])]) -> [String] -> CncLabels
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    ([String] -> (String, [String])) -> CoNLL -> [(String, [String])]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> (String, [String])
forall a. [[a]] -> ([a], [[a]])
collectTags (CoNLL -> [(String, [String])])
-> ([String] -> CoNLL) -> [String] -> [(String, [String])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (String -> [String]) -> [String] -> CoNLL
forall a b. (a -> b) -> [a] -> [b]
map String -> [String]
words

  ([String]
fs,[String]
ws) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition String -> Bool
chooseF ([String] -> ([String], [String]))
-> [String] -> ([String], [String])
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
uncomment ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
s

  --- choose is for compatibility with the general notation
  chooseW :: t Char -> Bool
chooseW t Char
line = Char -> t Char -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem Char
'(' t Char
line Bool -> Bool -> Bool
&&
                 Char -> t Char -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
'{' t Char
line
                   --- ignoring non-local (with "(") and abstract (without "{") rules
                   ---- TODO: this means that "(" cannot be a token

  chooseF :: String -> Bool
chooseF String
line = Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
1 String
line String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"@"  --- feature assignments have the form e.g. @N SgNom SgGen ; no spaces inside tags

  uncomment :: String -> String
uncomment String
line = case String
line of
    Char
'-':Char
'-':String
_ -> String
""
    Char
c:String
cs -> Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
uncomment String
cs
    String
_ -> String
line

  analyse :: String -> [(String, (String, (String -> String, String, String)))]
analyse String
line = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'{') String
line of
    (String
beg,Char
_:String
ws) -> case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'}') String
ws of
      (String
toks,Char
_:String
target) -> case (String -> [String]
getToks String
beg, String -> [String]
words String
target) of
        ([String]
funs,[    String
label,String
j]) -> [(String
fun, (String
tok, (String -> String
forall a. a -> a
id,       String
label,String
j))) | String
fun <- [String]
funs, String
tok <- String -> [String]
getToks String
toks]
        ([String]
funs,[String
pos,String
label,String
j]) -> [(String
fun, (String
tok, (String -> String -> String
forall a b. a -> b -> a
const String
pos,String
label,String
j))) | String
fun <- [String]
funs, String
tok <- String -> [String]
getToks String
toks]
        ([String], [String])
_ -> []
      (String, String)
_ -> []
    (String, String)
_ -> []
  merge :: [(a, (String, b))] -> (a, String -> Maybe b)
merge rules :: [(a, (String, b))]
rules@((a
fun,(String, b)
_):[(a, (String, b))]
_) = (a
fun, \String
tok ->
    case String -> [(String, b)] -> Maybe b
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
tok (((a, (String, b)) -> (String, b))
-> [(a, (String, b))] -> [(String, b)]
forall a b. (a -> b) -> [a] -> [b]
map (a, (String, b)) -> (String, b)
forall a b. (a, b) -> b
snd [(a, (String, b))]
rules) of
      Just b
new -> b -> Maybe b
forall (m :: * -> *) a. Monad m => a -> m a
return b
new
      Maybe b
_ -> String -> [(String, b)] -> Maybe b
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"*"  (((a, (String, b)) -> (String, b))
-> [(a, (String, b))] -> [(String, b)]
forall a b. (a -> b) -> [a] -> [b]
map (a, (String, b)) -> (String, b)
forall a b. (a, b) -> b
snd [(a, (String, b))]
rules)
    )
  getToks :: String -> [String]
getToks = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
unquote ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=String
",") ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
toks
  toks :: String -> [String]
toks String
s = case ReadS String
lex String
s of [(String
t,String
"")] -> [String
t] ; [(String
t,String
cc)] -> String
tString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String -> [String]
toks String
cc ; [(String, String)]
_ -> []
  unquote :: String -> String
unquote String
s = case String
s of Char
'"':cc :: String
cc@(Char
_:String
_) | String -> Char
forall a. [a] -> a
last String
cc Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' -> String -> String
forall a. [a] -> [a]
init String
cc ; String
_ -> String
s

  collectTags :: [[a]] -> ([a], [[a]])
collectTags ([a]
w:[[a]]
ws) = ([a] -> [a]
forall a. [a] -> [a]
tail [a]
w,[[a]]
ws)

-- added init to remove the last \n. otherwise, two empty lines are in between each sentence PK 17/12/2018
printCoNLL :: CoNLL -> String
printCoNLL :: CoNLL -> String
printCoNLL = String -> String
forall a. [a] -> [a]
init (String -> String) -> (CoNLL -> String) -> CoNLL -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String) -> (CoNLL -> [String]) -> CoNLL -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> String) -> CoNLL -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"\t")