{-# LANGUAGE RankNTypes, ViewPatterns #-}
module Test.Tasty.Patterns.Eval (Path, eval, withFields, asB) where

import Prelude hiding (Ordering(..))
import Control.Monad ((<=<))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)
import qualified Data.Sequence as Seq
import Data.Foldable
import Data.List (findIndex, intercalate, isInfixOf, isPrefixOf, tails)
import Data.Maybe
import Data.Char
import Test.Tasty.Patterns.Types
#if !MIN_VERSION_base(4,9,0)
import Control.Applicative
import Data.Traversable
#endif

type Path = Seq.Seq String

data Value
  = VN !Int
  | VS !Bool String
    -- ^ The 'Bool' is 'True' if the source of the string
    -- allows it to be numeric
  | Uninitialized
  deriving Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show

type M = ReaderT Path (Either String)

throwError :: String -> M a
throwError :: forall a. String -> M a
throwError String
s = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
s

asS :: Value -> M String
asS :: Value -> M String
asS Value
v = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
  case Value
v of
    VN Int
n -> forall a. Show a => a -> String
show Int
n
    VS Bool
_ String
s -> String
s
    Value
Uninitialized -> String
""

-- readMaybe was not in base-4.3 yet
parseN :: String -> Maybe Int
parseN :: String -> Maybe Int
parseN String
s =
  case forall a. Read a => String -> a
read String
s of
    [(Int
n, String
"")] -> forall a. a -> Maybe a
Just Int
n
    [(Int, String)]
_ -> forall a. Maybe a
Nothing

asN :: Value -> M Int
asN :: Value -> M Int
asN Value
v =
  case Value
v of
    VN Int
n -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
    VS Bool
True String
s ->
      case String -> Maybe Int
parseN String
s of
        Just Int
n -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
        Maybe Int
Nothing -> forall a. String -> M a
throwError forall a b. (a -> b) -> a -> b
$ String
"Not a number: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
s
    VS Bool
False String
s -> forall a. String -> M a
throwError forall a b. (a -> b) -> a -> b
$ String
"String is not numeric: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
s
    Value
Uninitialized -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
0

isN :: Value -> Bool
isN :: Value -> Bool
isN Value
v =
  case Value
v of
    VN Int
_ -> Bool
True
    Value
_ -> Bool
False

isNumeric :: Value -> Bool
isNumeric :: Value -> Bool
isNumeric Value
v =
  case Value
v of
    VS Bool
b String
s -> Bool
b Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust (String -> Maybe Int
parseN String
s)
    Value
_ -> Bool
True

asB :: Value -> M Bool
asB :: Value -> M Bool
asB Value
v = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
  case Value
v of
    VN Int
0 -> Bool
False
    VS Bool
_ String
"" -> Bool
False
    Value
_ -> Bool
True

fromB :: Bool -> Value
fromB :: Bool -> Value
fromB = Int -> Value
VN forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum

-- | Evaluate an awk expression
eval :: Expr -> M Value
eval :: Expr -> M Value
eval Expr
e0 =
  case Expr
e0 of
    IntLit Int
n -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Value
VN Int
n
    StringLit String
s -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> String -> Value
VS Bool
False String
s
    Expr
NF -> Int -> Value
VN forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Seq a -> Int
Seq.length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    Add Expr
e1 Expr
e2 -> (Int -> Int -> Int) -> Expr -> Expr -> M Value
binNumOp forall a. Num a => a -> a -> a
(+) Expr
e1 Expr
e2
    Sub Expr
e1 Expr
e2 -> (Int -> Int -> Int) -> Expr -> Expr -> M Value
binNumOp (-) Expr
e1 Expr
e2
    Neg Expr
e1 -> Int -> Value
VN forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> M Int
asN forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> M Value
eval Expr
e1)
    Not Expr
e1 -> Bool -> Value
fromB forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> M Bool
asB forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> M Value
eval Expr
e1)
    And Expr
e1 Expr
e2 -> (Bool -> Bool -> Bool) -> Expr -> Expr -> M Value
binLglOp Bool -> Bool -> Bool
(&&) Expr
e1 Expr
e2
    Or Expr
e1 Expr
e2  -> (Bool -> Bool -> Bool) -> Expr -> Expr -> M Value
binLglOp Bool -> Bool -> Bool
(||) Expr
e1 Expr
e2
    LT Expr
e1 Expr
e2 -> (forall a. Ord a => a -> a -> Bool) -> Expr -> Expr -> M Value
binCmpOp forall a. Ord a => a -> a -> Bool
(<)  Expr
e1 Expr
e2
    LE Expr
e1 Expr
e2 -> (forall a. Ord a => a -> a -> Bool) -> Expr -> Expr -> M Value
binCmpOp forall a. Ord a => a -> a -> Bool
(<=) Expr
e1 Expr
e2
    GT Expr
e1 Expr
e2 -> (forall a. Ord a => a -> a -> Bool) -> Expr -> Expr -> M Value
binCmpOp forall a. Ord a => a -> a -> Bool
(>)  Expr
e1 Expr
e2
    GE Expr
e1 Expr
e2 -> (forall a. Ord a => a -> a -> Bool) -> Expr -> Expr -> M Value
binCmpOp forall a. Ord a => a -> a -> Bool
(>=) Expr
e1 Expr
e2
    EQ Expr
e1 Expr
e2 -> (forall a. Ord a => a -> a -> Bool) -> Expr -> Expr -> M Value
binCmpOp forall a. Eq a => a -> a -> Bool
(==) Expr
e1 Expr
e2
    NE Expr
e1 Expr
e2 -> (forall a. Ord a => a -> a -> Bool) -> Expr -> Expr -> M Value
binCmpOp forall a. Eq a => a -> a -> Bool
(/=) Expr
e1 Expr
e2
    Concat Expr
e1 Expr
e2 -> Bool -> String -> Value
VS Bool
False forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. [a] -> [a] -> [a]
(++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> M String
asS forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> M Value
eval Expr
e1) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Value -> M String
asS forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> M Value
eval Expr
e2))
    If Expr
cond Expr
e1 Expr
e2 -> do
      Bool
condV <- Value -> M Bool
asB forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> M Value
eval Expr
cond
      if Bool
condV then Expr -> M Value
eval Expr
e1 else Expr -> M Value
eval Expr
e2
    Field Expr
e1 -> do
      Int
n <- Value -> M Int
asN forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> M Value
eval Expr
e1
      Path
fields <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Int
n forall a. Ord a => a -> a -> Bool
> forall a. Seq a -> Int
Seq.length Path
fields forall a. Num a => a -> a -> a
- Int
1
        then Value
Uninitialized
        else Bool -> String -> Value
VS Bool
True forall a b. (a -> b) -> a -> b
$ forall a. Seq a -> Int -> a
Seq.index Path
fields Int
n
    ERE String
pat -> do
      String
str <- forall a. Seq a -> Int -> a
Seq.index forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) r. Monad m => ReaderT r m r
ask forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
      forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Value
fromB forall a b. (a -> b) -> a -> b
$ String -> String -> Bool
match String
pat String
str
    Match Expr
e1 String
pat -> do
      String
str <- Value -> M String
asS forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> M Value
eval Expr
e1
      forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Value
fromB forall a b. (a -> b) -> a -> b
$ String -> String -> Bool
match String
pat String
str
    NoMatch Expr
e1 String
pat -> do
      String
str <- Value -> M String
asS forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> M Value
eval Expr
e1
      forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Value
fromB forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ String -> String -> Bool
match String
pat String
str
    ToUpperFn Expr
e1 ->
      Bool -> String -> Value
VS Bool
True forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> M String
asS forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> M Value
eval Expr
e1)
    ToLowerFn Expr
e1 ->
      Bool -> String -> Value
VS Bool
True forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> M String
asS forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> M Value
eval Expr
e1)
    SubstrFn Expr
e1 Expr
e2 Maybe Expr
mb_e3 -> do
      String
s <- Value -> M String
asS forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> M Value
eval Expr
e1
      Int
m <- Value -> M Int
asN forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> M Value
eval Expr
e2
      Maybe Int
mb_n <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Value -> M Int
asN forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Expr -> M Value
eval) Maybe Expr
mb_e3
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> String -> Value
VS Bool
True forall a b. (a -> b) -> a -> b
$
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall a. Int -> [a] -> [a]
take Maybe Int
mb_n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop (Int
mforall a. Num a => a -> a -> a
-Int
1) forall a b. (a -> b) -> a -> b
$ String
s
    LengthFn (forall a. a -> Maybe a -> a
fromMaybe (Expr -> Expr
Field (Int -> Expr
IntLit Int
0)) ->  Expr
e1) ->
      Int -> Value
VN forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> M String
asS forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> M Value
eval Expr
e1)
    MatchFn Expr
e1 String
pat -> do
      String
s <- Value -> M String
asS forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> M Value
eval Expr
e1
      forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Value
VN forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (forall a. Num a => a -> a -> a
+Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (String
pat forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]]
tails String
s

  where
    binNumOp :: (Int -> Int -> Int) -> Expr -> Expr -> M Value
binNumOp Int -> Int -> Int
op Expr
e1 Expr
e2 = Int -> Value
VN forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int -> Int
op forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> M Int
asN forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> M Value
eval Expr
e1) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Value -> M Int
asN forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> M Value
eval Expr
e2))
    binLglOp :: (Bool -> Bool -> Bool) -> Expr -> Expr -> M Value
binLglOp Bool -> Bool -> Bool
op Expr
e1 Expr
e2 = Bool -> Value
fromB forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Bool -> Bool
op forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> M Bool
asB forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> M Value
eval Expr
e1) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Value -> M Bool
asB forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> M Value
eval Expr
e2))
    binCmpOp :: (forall a . Ord a => a -> a -> Bool) -> Expr -> Expr -> M Value
    binCmpOp :: (forall a. Ord a => a -> a -> Bool) -> Expr -> Expr -> M Value
binCmpOp forall a. Ord a => a -> a -> Bool
op Expr
e1 Expr
e2 = do
      Value
v1 <- Expr -> M Value
eval Expr
e1
      Value
v2 <- Expr -> M Value
eval Expr
e2
      let
        compareAsNumbers :: Bool
compareAsNumbers =
          Value -> Bool
isN Value
v1 Bool -> Bool -> Bool
&& Value -> Bool
isNumeric Value
v2 Bool -> Bool -> Bool
||
          Value -> Bool
isN Value
v2 Bool -> Bool -> Bool
&& Value -> Bool
isNumeric Value
v1
      if Bool
compareAsNumbers
        then Bool -> Value
fromB forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Ord a => a -> a -> Bool
op forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> M Int
asN Value
v1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> M Int
asN Value
v2)
        else Bool -> Value
fromB forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Ord a => a -> a -> Bool
op forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> M String
asS Value
v1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> M String
asS Value
v2)

match
  :: String -- ^ pattern
  -> String -- ^ string
  -> Bool
match :: String -> String -> Bool
match String
pat String
str = String
pat forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
str

-- | Run the @M@ monad with a given list of fields
--
-- The field list should not include @$0@; it's calculated automatically.
withFields :: Seq.Seq String -> M a -> Either String a
withFields :: forall a. Path -> M a -> Either String a
withFields Path
fields M a
a = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT M a
a (String
whole forall a. a -> Seq a -> Seq a
Seq.<| Path
fields)
  where whole :: String
whole = forall a. [a] -> [[a]] -> [a]
intercalate String
"." forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Path
fields