module GF.Compile.ExampleBased (
  parseExamplesInGrammar,
  configureExBased
  ) where

import PGF
--import PGF.Probabilistic
--import PGF.Morphology
--import GF.Compile.ToAPI

import Data.List

parseExamplesInGrammar :: ExConfiguration -> FilePath -> IO (FilePath,[String])
parseExamplesInGrammar :: ExConfiguration -> FilePath -> IO (FilePath, [FilePath])
parseExamplesInGrammar ExConfiguration
conf FilePath
file = do
  FilePath
src <- FilePath -> IO FilePath
readFile FilePath
file                             -- .gfe
  let file' :: FilePath
file' = Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
file Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) FilePath
file FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"gf"  -- .gf
  [FilePath]
ws <- ExConfiguration -> FilePath -> FilePath -> IO [FilePath]
convertFile ExConfiguration
conf FilePath
src FilePath
file'
  (FilePath, [FilePath]) -> IO (FilePath, [FilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
file',[FilePath]
ws)

convertFile :: ExConfiguration -> String -> FilePath -> IO [String]
convertFile :: ExConfiguration -> FilePath -> FilePath -> IO [FilePath]
convertFile ExConfiguration
conf FilePath
src FilePath
file = do
  FilePath -> FilePath -> IO ()
writeFile FilePath
file FilePath
"" -- "-- created by example-based grammar writing in GF\n"
  [FilePath] -> FilePath -> IO [FilePath]
conv [] FilePath
src
 where
  conv :: [FilePath] -> FilePath -> IO [FilePath]
conv [FilePath]
ws FilePath
s = do
    ((FilePath, FilePath)
cex,FilePath
end) <- FilePath -> IO ((FilePath, FilePath), FilePath)
findExample FilePath
s
    if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
end then [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort [FilePath]
ws)) else do
      [FilePath]
ws2 <- (FilePath, FilePath) -> IO [FilePath]
convEx (FilePath, FilePath)
cex
      [FilePath] -> FilePath -> IO [FilePath]
conv ([FilePath]
ws2 [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
ws) FilePath
end
  findExample :: FilePath -> IO ((FilePath, FilePath), FilePath)
findExample FilePath
s = case FilePath
s of
    Char
'%':Char
'e':Char
'x':FilePath
cs -> ((FilePath, FilePath), FilePath)
-> IO ((FilePath, FilePath), FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (((FilePath, FilePath), FilePath)
 -> IO ((FilePath, FilePath), FilePath))
-> ((FilePath, FilePath), FilePath)
-> IO ((FilePath, FilePath), FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> ((FilePath, FilePath), FilePath)
getExample FilePath
cs
    Char
c:FilePath
cs -> FilePath -> IO ()
appf [Char
c] IO ()
-> IO ((FilePath, FilePath), FilePath)
-> IO ((FilePath, FilePath), FilePath)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> IO ((FilePath, FilePath), FilePath)
findExample FilePath
cs
    FilePath
_ -> ((FilePath, FilePath), FilePath)
-> IO ((FilePath, FilePath), FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return ((FilePath, FilePath)
forall a. HasCallStack => a
undefined,FilePath
s)
  getExample :: FilePath -> ((FilePath, FilePath), FilePath)
getExample FilePath
s = 
    let 
      (FilePath
cat,FilePath
exend) = (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'"') FilePath
s
      (FilePath
ex,   FilePath
end) = (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'"') (FilePath -> FilePath
forall a. [a] -> [a]
tail FilePath
exend)
    in (([FilePath] -> FilePath
unwords (FilePath -> [FilePath]
words FilePath
cat),FilePath
ex), FilePath -> FilePath
forall a. [a] -> [a]
tail FilePath
end)  -- quotes ignored
  pgf :: PGF
pgf = ExConfiguration -> PGF
resource_pgf ExConfiguration
conf
  morpho :: Morpho
morpho = ExConfiguration -> Morpho
resource_morpho ExConfiguration
conf
  lang :: Language
lang = ExConfiguration -> Language
language ExConfiguration
conf 
  convEx :: (FilePath, FilePath) -> IO [FilePath]
convEx (FilePath
cat,FilePath
ex) = do
    FilePath -> IO ()
appn FilePath
"("
    let typ :: Type
typ = Type -> (Type -> Type) -> Maybe Type -> Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> Type
forall a. HasCallStack => FilePath -> a
error FilePath
"no valid cat") Type -> Type
forall a. a -> a
id (Maybe Type -> Type) -> Maybe Type -> Type
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe Type
readType FilePath
cat
    [FilePath]
ws <- case (ParseOutput, BracketedString) -> ParseOutput
forall a b. (a, b) -> a
fst (PGF
-> Language
-> Type
-> Maybe Int
-> FilePath
-> (ParseOutput, BracketedString)
parse_ PGF
pgf Language
lang Type
typ (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
4) FilePath
ex) of
      ParseFailed Int
_ -> do
        let ws :: [FilePath]
ws = Morpho -> [FilePath] -> [FilePath]
morphoMissing Morpho
morpho (FilePath -> [FilePath]
words FilePath
ex)
        FilePath -> IO ()
appv (FilePath
"WARNING: cannot parse example " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
ex) 
        case [FilePath]
ws of
          [] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          [FilePath]
_  -> FilePath -> IO ()
appv (FilePath
"  missing words: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords [FilePath]
ws)
        [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath]
ws
      TypeError [(Int, TcError)]
_ ->
        [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      ParseOutput
ParseIncomplete ->
        [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      ParseOk [Tree]
ts ->
        case [Tree] -> [FilePath]
rank [Tree]
ts of
          (FilePath
t:[FilePath]
tt) -> do
            if [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
tt 
              then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              else FilePath -> IO ()
appv (FilePath
"WARNING: ambiguous example " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
ex) 
            FilePath -> IO ()
appn FilePath
t 
            (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FilePath -> IO ()
appn (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"  --- " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++)) [FilePath]
tt
            FilePath -> IO ()
appn FilePath
")" 
            [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [] 
    [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath]
ws
  rank :: [Tree] -> [FilePath]
rank [Tree]
ts = [ExConfiguration -> Tree -> FilePath
printExp ExConfiguration
conf Tree
t FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"  -- " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Double -> FilePath
forall a. Show a => a -> FilePath
show Double
p | (Tree
t,Double
p) <- PGF -> [Tree] -> [(Tree, Double)]
rankTreesByProbs PGF
pgf [Tree]
ts]
  appf :: FilePath -> IO ()
appf = FilePath -> FilePath -> IO ()
appendFile FilePath
file
  appn :: FilePath -> IO ()
appn FilePath
s = FilePath -> IO ()
appf FilePath
s IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> IO ()
appf FilePath
"\n"
  appv :: FilePath -> IO ()
appv FilePath
s = FilePath -> IO ()
appn (FilePath
"--- " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
s) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> IO ()
putStrLn FilePath
s

data ExConfiguration = ExConf {
  ExConfiguration -> PGF
resource_pgf    :: PGF,
  ExConfiguration -> Morpho
resource_morpho :: Morpho,
  ExConfiguration -> Bool
verbose  :: Bool,
  ExConfiguration -> Language
language :: Language,
  ExConfiguration -> Tree -> FilePath
printExp :: Tree -> String
  }

configureExBased :: PGF -> Morpho -> Language -> (Tree -> String) -> ExConfiguration
configureExBased :: PGF -> Morpho -> Language -> (Tree -> FilePath) -> ExConfiguration
configureExBased PGF
pgf Morpho
morpho Language
lang Tree -> FilePath
pr = PGF
-> Morpho
-> Bool
-> Language
-> (Tree -> FilePath)
-> ExConfiguration
ExConf PGF
pgf Morpho
morpho Bool
False Language
lang Tree -> FilePath
pr