{-# OPTIONS -fglasgow-exts #-}
module CondParser where 
import Parselib (Parser, chainl, ops, token, string, many1, notchars, bracket, notchar, readparseM, char,(+++))
--import Parselib as PL ((+++)) 
import Control.Monad
import Misc


combor = mkcombpred (||)
comband = mkcombpred (&&)
mkcombpred p st1 st2 = \s -> (st1 s) `p` (st2 s)

type PTest = String -> Bool

condParser :: Parser PTest
condParser = chainl term combOp (const True)
  where combOp = ops [(token $ string "or", combor)
                       ,(token $ string "and", comband)]

        term = token $ testAtom +++ bracket ( char '(' ) condParser ( char ')' ) 
        testAtom :: Parser PTest
        testAtom  = foldr1 (+++) [ pOp ("=",(==))
                                   , pOp ( ">>>", (>>>) )
                                   , pOp ( ">i", strGTI )
                                   , pOp ( "<i", strLTI )
                                   , pOp ( ">f", strGTF )
                                   , pOp ( "<f", strLTF )
                                   , pOp ( ">", strGT )
                                   , pOp ( "<", strLT )
                                 ]
          where pOp :: ( String , (String -> String -> Bool ) ) -> Parser PTest
                pOp (opstring,f) = do 
                  string opstring 
                  s <- mystring
                  return ( f s )

        mystring = unquotedS +++ quotedS    
          where 
            unquotedS = many1 ( notchars [ '\"' ,' ' ] )
            quotedS = bracket (char '\"') (many1 $ notchar '\"') (char '\"')

str1 >>> str2 = str1 `isInfixOf` str2

strGTI = intcmp (>)
strLTI = intcmp (<)

strGT = strGTF
strLT = strLTF
strGTF = floatcmp (>)
strLTF = floatcmp (<)

flexcmp reader op s1 s2 = cmp ( (reader s1 ), (reader s2 ) )
  where 
    cmp ( (Just f1) , (Just f2) ) = f2 `op` f1  
    cmp _ = False

floatcmp = flexcmp readMbFloat
intcmp = flexcmp readMbInt

mkTestPlaceholder, mkTestParse, mkTestReadsPrec, mkTestReadBool :: String -> String -> Bool
mkTestPlaceholder x y = False
mkTestReadsPrec x y = ( fst . head . readsPrec 0 ) x 
mkTestReadBool x y = readBool x
  where readBool x = maybe False id (readMbBool x)


mkTestParse s = maybe (const False) id (readparseM "mkTestParse" condParser s)



readMbFloat x = (myRead x :: Maybe Float)
readMbBool x = (myRead x :: Maybe Bool)
readMbInt x = (myRead x :: Maybe Int)


myRead x = case readsPrec 0 x of
  [] -> fail $ "myRead: "++x
  [(v,leftover)] -> if (null leftover)
    then return v
    else fail ( "myRead: "++x )
  _ -> fail $ "myRead, multiple parses"