{-# 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