{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module OrgStat.Scope
( AstPath (..)
, isSubPath
, existsPath
, ScopeModifier (..)
, applyModifiers
) where
import qualified Prelude
import Universum
import Control.Lens (to)
import Control.Monad.Except (throwError)
import qualified Data.Text as T
import OrgStat.Ast (Org, atDepth, orgClocks, orgSubtrees, orgTags, orgTitle, traverseTree)
newtype AstPath = AstPath
{ getAstPath :: [Text]
} deriving (Eq, Ord)
instance Show AstPath where
show (AstPath path)
| null path = "<null_ast_path>"
| otherwise = intercalate "/" (map T.unpack path)
isSubPath :: AstPath -> AstPath -> Bool
isSubPath (AstPath l1) (AstPath l2) = l1 `isPrefixOf` l2
atPath :: AstPath -> Lens' Org (Maybe Org)
atPath (AstPath []) f o = fromMaybe o <$> f (Just o)
atPath (AstPath p) f o = atPathDo p o
where
atPathDo [] org = f Nothing $> org
atPathDo (x:xs) org =
let match = find ((== x) . view orgTitle) $ org ^. orgSubtrees
modified foo = org & orgSubtrees %~ foo . filter ((/= match) . Just)
fmapFoo Nothing = modified id
fmapFoo (Just o') = modified (o' :)
in case (xs,match) of
(_,Nothing) -> f Nothing $> org
([],_) -> fmap fmapFoo $ f match
(cont,Just m) -> fmap (\new -> modified (new:)) $ atPathDo cont m
existsPath :: AstPath -> Org -> Bool
existsPath p o = o ^. atPath p . to isJust
data ScopeModifier
= ModPruneSubtree AstPath Int
| ModFilterTag Text
| ModSquash AstPath
| ModSelectSubtree AstPath
deriving (Show,Eq,Ord)
data ModifierError
= MEConflicting ScopeModifier ScopeModifier Text
| MEWrongParam ScopeModifier Text
deriving (Show,Typeable)
instance Exception ModifierError
applyModifier :: ScopeModifier -> Org -> Either ModifierError Org
applyModifier m@(ModPruneSubtree path depth) org = do
unless (depth >= 0) $ throwError $ MEWrongParam m "Depth should be >= 0"
unless (existsPath path org) $
throwError $ MEWrongParam m $ "Path " <> show path <> " doesn't exist"
let subclocks o' = o' & orgClocks .~ (concatMap (view orgClocks) $ o' ^.. traverseTree)
& orgSubtrees .~ []
let pruneChildren o = o & atDepth depth %~ subclocks
pure $ org & atPath path %~ (\x -> maybe x (Just . pruneChildren) x)
applyModifier m@(ModSelectSubtree path) org = do
unless (existsPath path org) $
throwError $ MEWrongParam m $ "Path " <> show path <> " doesn't exist"
pure $
fromMaybe (error "applyModifier@ModSelectSubtree is broken") $
org ^. atPath path
applyModifier (ModFilterTag tag) o0 = do
let matchesTag o = any (== tag) (o ^. orgTags)
let dfs :: Org -> Maybe Org
dfs o | matchesTag o = Just o
| otherwise = case mapMaybe dfs (o ^. orgSubtrees) of
[] -> Nothing
xs -> Just $ o & orgSubtrees .~ xs
Right $ o0 & orgSubtrees %~ mapMaybe dfs
applyModifier _ org = pure org
applyModifiers :: Org -> [ScopeModifier] -> Either ModifierError Org
applyModifiers org s = do
foldrM applyModifier org mods
where
mods = sort s