{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}
module Parsing.TestProgram where

import System.IO ( stdin, hGetContents )
import System.Environment ( getArgs, getProgName )

import GHC.Exts
import Control.Monad
import Control.Applicative (pure)
import Parsing.Chart hiding (fingerprint,mkTree)
import Data.Matrix.Quad
import Data.Pair
import Algebra.RingUtils

type Verbosity = Int

putStrV :: Verbosity -> String -> IO ()
putStrV :: Verbosity -> String -> IO ()
putStrV Verbosity
v String
s = if Verbosity
v forall a. Ord a => a -> a -> Bool
> Verbosity
1 then String -> IO ()
putStrLn String
s else forall (m :: * -> *) a. Monad m => a -> m a
return ()


mainTest :: forall category token. 
            (RingP [(category,Any)], Eq category) =>
         ((category,Any) -> String) ->
         (Bool -> token -> Pair [(category,Any)]) ->
         (String -> [token]) ->
         (token -> (Int,Int)) -> 
         (category -> String) -> 
         (category -> [category]) ->
         IO ()
mainTest :: forall category token.
(RingP [(category, Any)], Eq category) =>
((category, Any) -> String)
-> (Bool -> token -> Pair [(category, Any)])
-> (String -> [token])
-> (token -> (Verbosity, Verbosity))
-> (category -> String)
-> (category -> [category])
-> IO ()
mainTest (category, Any) -> String
showAst Bool -> token -> Pair [(category, Any)]
cnfToksToCat String -> [token]
myLLexer token -> (Verbosity, Verbosity)
getTokPos category -> String
describe category -> [category]
follows = 
  do [String]
args <- IO [String]
getArgs
     case [String]
args of
       [] -> Handle -> IO String
hGetContents Handle
stdin forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {p}. p -> String -> IO ()
run Integer
2
       String
"-s":[String]
fs -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall {p}. p -> String -> IO ()
runFile Integer
0) [String]
fs
       [String]
fs -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall {p}. p -> String -> IO ()
runFile Integer
2) [String]
fs
       
 where 
  neighbors :: category -> category -> Bool
neighbors category
a category
b = category
b forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` category -> [category]
follows category
a
  showResults :: [(category,Any)] -> IO ()
  showResults :: [(category, Any)] -> IO ()
showResults [(category, Any)]
x = do
        String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Verbosity
length [(category, Any)]
x) forall a. [a] -> [a] -> [a]
++ String
" results"
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(category, Any)]
x forall a b. (a -> b) -> a -> b
$ \(category
cat,Any
ast) -> do
          String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ category -> String
describe category
cat        
          String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ (category, Any) -> String
showAst (category
cat,Any
ast)
  
  runFile :: p -> String -> IO ()
runFile p
v String
f = String -> IO ()
putStrLn String
f forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO String
readFile String
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {p}. p -> String -> IO ()
run p
v
  run :: p -> String -> IO ()
run p
v String
s = 
    do case [(Verbosity, [(category, Any)], Verbosity)]
rs of
         [(Verbosity
_,[(category, Any)]
x,Verbosity
_)] -> [(category, Any)] -> IO ()
showResults [(category, Any)]
x
         [(Verbosity, [(category, Any)], Verbosity)]
_ -> do let errs :: [((Verbosity, [(category, Any)], Verbosity),
  (Verbosity, [(category, Any)], Verbosity))]
errs = forall {a}. [a] -> [(a, a)]
pairs [(Verbosity, [(category, Any)], Verbosity)]
rs
                     best :: (Bool, Verbosity)
best = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {b} {b} {b}.
Num b =>
((b, [(category, b)], b), (b, [(category, b)], b)) -> (Bool, b)
quality [((Verbosity, [(category, Any)], Verbosity),
  (Verbosity, [(category, Any)], Verbosity))]
errs                     
                 forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b} {a} {b} {c}.
[token]
-> ((a, [(category, b)], Verbosity), (a, [(category, b)], c))
-> String
showErr [token]
ts) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\((Verbosity, [(category, Any)], Verbosity),
 (Verbosity, [(category, Any)], Verbosity))
x -> forall {b} {b} {b}.
Num b =>
((b, [(category, b)], b), (b, [(category, b)], b)) -> (Bool, b)
quality ((Verbosity, [(category, Any)], Verbosity),
 (Verbosity, [(category, Any)], Verbosity))
x forall a. Eq a => a -> a -> Bool
== (Bool, Verbosity)
best) [((Verbosity, [(category, Any)], Verbosity),
  (Verbosity, [(category, Any)], Verbosity))]
errs
       String -> String -> IO ()
writeFile String
"cnf.xpm" ([String] -> String
genXPM forall a b. (a -> b) -> a -> b
$ forall {a}. AbelianGroupZ a => SomeTri a -> [String]
fingerprint SomeTri [(category, Any)]
chart)
    where ts :: [token]
ts = String -> [token]
myLLexer String
s
          chart :: SomeTri [(category, Any)]
chart = forall a. RingP a => [Pair a] -> SomeTri a
mkTree forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> token -> Pair [(category, Any)]
cnfToksToCat (forall a. [a] -> [a]
cycle [Bool
False,Bool
True]) [token]
ts 
          rs :: [(Verbosity, [(category, Any)], Verbosity)]
rs = forall a.
AbelianGroupZ a =>
SomeTri a -> [(Verbosity, a, Verbosity)]
results SomeTri [(category, Any)]
chart
  
  showTokPos :: (Int,Int) -> String
  showTokPos :: (Verbosity, Verbosity) -> String
showTokPos (Verbosity
l,Verbosity
c) = forall a. Show a => a -> String
show Verbosity
l forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Verbosity
cforall a. Num a => a -> a -> a
-Verbosity
1)

  showPos :: [token] -> Int -> String
  showPos :: [token] -> Verbosity -> String
showPos [token]
ts Verbosity
x = (Verbosity, Verbosity) -> String
showTokPos (token -> (Verbosity, Verbosity)
getTokPos forall a b. (a -> b) -> a -> b
$ [token]
ts forall a. [a] -> Verbosity -> a
!! Verbosity
x)
  
  showErr :: [token]
-> ((a, [(category, b)], Verbosity), (a, [(category, b)], c))
-> String
showErr [token]
ts ((a
_,[(category, b)]
x',Verbosity
p),(a
_,[(category, b)]
y',c
_)) = 
     [token] -> Verbosity -> String
showPos [token]
ts Verbosity
p forall a. [a] -> [a] -> [a]
++ String
": cannot combine " forall a. [a] -> [a] -> [a]
++ forall {b}. [(category, b)] -> String
showBestCat [(category, b)]
x' forall a. [a] -> [a] -> [a]
++ String
" with " forall a. [a] -> [a] -> [a]
++ forall {b}. [(category, b)] -> String
showBestCat [(category, b)]
y'

  quality :: ((b, [(category, b)], b), (b, [(category, b)], b)) -> (Bool, b)
quality (a :: (b, [(category, b)], b)
a@(b
_,[(category, b)]
x',b
p),b :: (b, [(category, b)], b)
b@(b
_,[(category, b)]
y',b
_)) = (forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ category -> category -> Bool
neighbors category
x category
y | category
x <- forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(category, b)]
x', category
y <- forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(category, b)]
y'],
                                     (forall {a} {b}. Num a => (a, b, a) -> a
resSz (b, [(category, b)], b)
a) forall a. Num a => a -> a -> a
Prelude.+ (forall {a} {b}. Num a => (a, b, a) -> a
resSz (b, [(category, b)], b)
b))
     

  showBestCat :: [(category, b)] -> String
showBestCat ((category
x,b
_):[(category, b)]
_) = category -> String
describe category
x

pairs :: [a] -> [(a, a)]
pairs (a
x:a
y:[a]
xs) = (a
x,a
y)forall a. a -> [a] -> [a]
:[a] -> [(a, a)]
pairs (a
yforall a. a -> [a] -> [a]
:[a]
xs)
pairs [a]
_ = []

resSz :: (a, b, a) -> a
resSz (a
i,b
_,a
j) = a
jforall a. Num a => a -> a -> a
-a
i