Eval.hs

-- This file is part of khph.
--
-- Copyright 2016 Bryan Gardiner <bog@khumba.net>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE CPP #-}

-- | Evaluator for a parsed query.
module Khph.Query.Eval (queryApply) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<*>))
#endif
import Data.List (intercalate, isInfixOf, isPrefixOf, isSuffixOf)
import qualified Data.Set as Set
import Khph.Config (configSourceDirs)
import Khph.Project.Base
import Khph.Project.Monad
import Khph.Query.Base
import Khph.Util
import System.FilePath (pathSeparator)

-- | Evaluates a query for a specific entry, returning whether the query matches
-- the entry.
queryApply :: MonadProject m => Query -> Entry m -> m Bool
queryApply logic entry = logicApply logic $ \query -> case query of
  QueryLink listPredicate -> do
    links <- (++) <$>
             (map (\path -> (path, HardLink)) <$> entryHardLinks entry) <*>
             (map (\path -> (path, SoftLink)) <$> entrySoftLinks entry)
    listPredicateApply listPredicate queryLink links
  QueryTag listPredicate -> do
    tags <- entryTags entry
    listPredicateApply listPredicate (\q xs -> queryTree tagToComponents q xs) $
      map tagToComponents tags

queryLink :: MonadProject m => LinkQuery -> (ProjectPath, LinkType) -> m Bool
queryLink logic (projectPath, linkType) = logicApply logic $ \query -> case query of
  LinkTypeIs typ -> return $ typ == linkType
  LinkMatchesEntrySpec entrySpec -> case entrySpec of
    EntrySpecAbsolute components ->
      return $ projectPathToComponents projectPath == components
    EntrySpecRelative components -> do
      currentPath <- getCurrentPathOrDie $ "running query " ++ show query
      return $ projectPath == projectPathAppendComponents currentPath components
    EntrySpecByName name ->
      return $ maybeLast (projectPathToComponents projectPath) == Just name
  LinkIsSourcePath ->
    any (\sourceDir -> projectPathIsPrefixOf sourceDir projectPath) .
    Set.toList .
    configSourceDirs <$>
    getConfig
  LinkStringQuery maybeComponent stringQuery ->
    queryString stringQuery $
    intercalate [pathSeparator] $
    (case maybeComponent of
      Nothing -> id
      Just DirectoryComponent -> butLast
      Just FileComponent -> (:[]) . last) $
    projectPathToComponents projectPath
  LinkTreeQuery treeQuery ->
    queryTree id treeQuery $ projectPathToComponents projectPath

queryString :: MonadProject m => StringQuery -> String -> m Bool
queryString logic xs = logicApply logic $ \query -> return $ case query of
  StringEq ys -> xs == ys
  StringContains ys -> ys `isInfixOf` xs  -- TODO This is terribly inefficient.
  StringStartsWith ys -> ys `isPrefixOf` xs
  StringEndsWith ys -> ys `isSuffixOf` xs

queryTree :: MonadProject m => Eq b => (a -> [b]) -> TreeQuery a -> [b] -> m Bool
queryTree resolve logic xs = logicApply logic $ \query -> return $ case query of
  TreeAt ys' -> xs == resolve ys'
  TreeAtAbove ys' -> xs `isPrefixOf` resolve ys'
  TreeAbove ys' -> let ys = resolve ys'
                   in xs `isPrefixOf` ys && length xs < length ys
  TreeAtBelow ys' -> resolve ys' `isPrefixOf` xs
  TreeBelow ys' -> let ys = resolve ys'
                   in ys `isPrefixOf` xs && length ys < length xs

logicApply :: MonadProject m => Logic q -> (q -> m Bool) -> m Bool
logicApply logic eval = case logic of
  LogicQuery query -> eval query
  LogicTrue -> return True
  LogicFalse -> return False
  LogicNot logic' -> not <$> logicApply logic' eval
  LogicAnd logics -> allM (flip logicApply eval) logics
  LogicOr logics -> anyM (flip logicApply eval) logics

listPredicateApply :: MonadProject m => ListPredicate q -> (q -> a -> m Bool) -> [a] -> m Bool
listPredicateApply p f xs = case p of
  All q -> allM (f q) xs
  All1 q -> if null xs then return False else allM (f q) xs
  Some q -> anyM (f q) xs
  None q -> not <$> anyM (f q) xs
  Exists -> return $ not $ null xs
  DoesNotExist -> return $ null xs