{-# 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 Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
> Verbosity
1 then String -> IO ()
putStrLn String
s else () -> IO ()
forall a. a -> IO a
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 IO String -> (String -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Integer -> String -> IO ()
forall {a}. (Ord a, Num a) => String -> a -> String -> IO ()
run String
"stdin" Integer
2
       String
"-s":[String]
fs -> (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Integer -> String -> IO ()
forall {a}. (Ord a, Num a) => a -> String -> IO ()
runFile Integer
0) [String]
fs
       [String]
fs -> (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Integer -> String -> IO ()
forall {a}. (Ord a, Num a) => a -> String -> IO ()
runFile Integer
2) [String]
fs

 where
  neighbors :: category -> category -> Bool
neighbors category
a category
b = category
b category -> [category] -> Bool
forall a. Eq a => a -> [a] -> Bool
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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> String
forall a. Show a => a -> String
show ([(category, Any)] -> Verbosity
forall a. [a] -> Verbosity
forall (t :: * -> *) a. Foldable t => t a -> Verbosity
length [(category, Any)]
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" results"
        [(category, Any)] -> ((category, Any) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(category, Any)]
x (((category, Any) -> IO ()) -> IO ())
-> ((category, Any) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(category
cat,Any
ast) -> do
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ category -> String
describe category
cat
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ (category, Any) -> String
showAst (category
cat,Any
ast)

  runFile :: a -> String -> IO ()
runFile a
v String
f = String -> IO ()
putStrLn String
f IO () -> IO String -> IO String
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO String
readFile String
f IO String -> (String -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> a -> String -> IO ()
forall {a}. (Ord a, Num a) => String -> a -> String -> IO ()
run String
f a
v
  run :: String -> a -> String -> IO ()
run String
f a
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 = [(Verbosity, [(category, Any)], Verbosity)]
-> [((Verbosity, [(category, Any)], Verbosity),
     (Verbosity, [(category, Any)], Verbosity))]
forall {a}. [a] -> [(a, a)]
pairs [(Verbosity, [(category, Any)], Verbosity)]
rs
                     best :: (Bool, Verbosity)
best = [(Bool, Verbosity)] -> (Bool, Verbosity)
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([(Bool, Verbosity)] -> (Bool, Verbosity))
-> [(Bool, Verbosity)] -> (Bool, Verbosity)
forall a b. (a -> b) -> a -> b
$ (((Verbosity, [(category, Any)], Verbosity),
  (Verbosity, [(category, Any)], Verbosity))
 -> (Bool, Verbosity))
-> [((Verbosity, [(category, Any)], Verbosity),
     (Verbosity, [(category, Any)], Verbosity))]
-> [(Bool, Verbosity)]
forall a b. (a -> b) -> [a] -> [b]
map ((Verbosity, [(category, Any)], Verbosity),
 (Verbosity, [(category, Any)], Verbosity))
-> (Bool, Verbosity)
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
                 (((Verbosity, [(category, Any)], Verbosity),
  (Verbosity, [(category, Any)], Verbosity))
 -> IO ())
-> [((Verbosity, [(category, Any)], Verbosity),
     (Verbosity, [(category, Any)], Verbosity))]
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn (String -> IO ())
-> (((Verbosity, [(category, Any)], Verbosity),
     (Verbosity, [(category, Any)], Verbosity))
    -> String)
-> ((Verbosity, [(category, Any)], Verbosity),
    (Verbosity, [(category, Any)], Verbosity))
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [token]
-> ((Verbosity, [(category, Any)], Verbosity),
    (Verbosity, [(category, Any)], Verbosity))
-> String
forall {a} {b} {a} {b} {c}.
[token]
-> ((a, [(category, b)], Verbosity), (a, [(category, b)], c))
-> String
showErr [token]
ts) ([((Verbosity, [(category, Any)], Verbosity),
   (Verbosity, [(category, Any)], Verbosity))]
 -> IO ())
-> [((Verbosity, [(category, Any)], Verbosity),
     (Verbosity, [(category, Any)], Verbosity))]
-> IO ()
forall a b. (a -> b) -> a -> b
$ (((Verbosity, [(category, Any)], Verbosity),
  (Verbosity, [(category, Any)], Verbosity))
 -> Bool)
-> [((Verbosity, [(category, Any)], Verbosity),
     (Verbosity, [(category, Any)], Verbosity))]
-> [((Verbosity, [(category, Any)], Verbosity),
     (Verbosity, [(category, Any)], Verbosity))]
forall a. (a -> Bool) -> [a] -> [a]
filter (\((Verbosity, [(category, Any)], Verbosity),
 (Verbosity, [(category, Any)], Verbosity))
x -> ((Verbosity, [(category, Any)], Verbosity),
 (Verbosity, [(category, Any)], Verbosity))
-> (Bool, Verbosity)
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 (Bool, Verbosity) -> (Bool, Verbosity) -> Bool
forall a. Eq a => a -> a -> Bool
== (Bool, Verbosity)
best) [((Verbosity, [(category, Any)], Verbosity),
  (Verbosity, [(category, Any)], Verbosity))]
errs
       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
v a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
         String -> String -> IO ()
writeFile (String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".xpm") ([String] -> String
genXPM ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ SomeTri [(category, Any)] -> [String]
forall {a}. AbelianGroupZ a => SomeTri a -> [String]
fingerprint SomeTri [(category, Any)]
chart)
         let scatt :: String
scatt = SomeTri [(category, Any)] -> String
forall {a}. AbelianGroup a => SomeTri a -> String
scatterplot SomeTri [(category, Any)]
chart
         String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Scatterplot data size:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Verbosity -> String
forall a. Show a => a -> String
show (String -> Verbosity
forall a. [a] -> Verbosity
forall (t :: * -> *) a. Foldable t => t a -> Verbosity
length String
scatt)
         String -> String -> IO ()
writeFile (String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".data") String
scatt
    where ts :: [token]
ts = String -> [token]
myLLexer String
s
          chart :: SomeTri [(category, Any)]
chart = [Pair [(category, Any)]] -> SomeTri [(category, Any)]
forall a. RingP a => [Pair a] -> SomeTri a
mkTree ([Pair [(category, Any)]] -> SomeTri [(category, Any)])
-> [Pair [(category, Any)]] -> SomeTri [(category, Any)]
forall a b. (a -> b) -> a -> b
$ (Bool -> token -> Pair [(category, Any)])
-> [Bool] -> [token] -> [Pair [(category, Any)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> token -> Pair [(category, Any)]
cnfToksToCat ([Bool] -> [Bool]
forall a. HasCallStack => [a] -> [a]
cycle [Bool
False,Bool
True]) [token]
ts
          rs :: [(Verbosity, [(category, Any)], Verbosity)]
rs = SomeTri [(category, Any)]
-> [(Verbosity, [(category, Any)], Verbosity)]
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) = Verbosity -> String
forall a. Show a => a -> String
show Verbosity
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Verbosity -> String
forall a. Show a => a -> String
show (Verbosity
cVerbosity -> Verbosity -> Verbosity
forall 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 (token -> (Verbosity, Verbosity))
-> token -> (Verbosity, Verbosity)
forall a b. (a -> b) -> a -> b
$ [token]
ts [token] -> Verbosity -> token
forall a. HasCallStack => [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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": cannot combine " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(category, b)] -> String
forall {b}. [(category, b)] -> String
showBestCat [(category, b)]
x' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(category, b)] -> String
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
_)) = ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ category -> category -> Bool
neighbors category
x category
y | category
x <- ((category, b) -> category) -> [(category, b)] -> [category]
forall a b. (a -> b) -> [a] -> [b]
map (category, b) -> category
forall a b. (a, b) -> a
fst [(category, b)]
x', category
y <- ((category, b) -> category) -> [(category, b)] -> [category]
forall a b. (a -> b) -> [a] -> [b]
map (category, b) -> category
forall a b. (a, b) -> a
fst [(category, b)]
y'],
                                     ((b, [(category, b)], b) -> b
forall {a} {b}. Num a => (a, b, a) -> a
resSz (b, [(category, b)], b)
a) b -> b -> b
forall a. Num a => a -> a -> a
Prelude.+ ((b, [(category, b)], b) -> b
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)(a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
:[a] -> [(a, a)]
pairs (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)
pairs [a]
_ = []

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