diohsc-0.1.1: CommandLine.hs

-- This file is part of Diohsc
-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation, or any later version.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see http://www.gnu.org/licenses/.

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Safe #-}

module CommandLine
    ( CommandLine(..)
    , CommandArg(..)
    , ElemsSpecs
    , PTarget(..)
    , parseCommandLine
    , parseCommand
    , resolveElemsSpecs
    ) where

import Control.Monad (guard, liftM2, mzero)
import Data.Bifunctor (first)
import Data.Char (isAlphaNum)
import Data.List (foldl')
import Data.Maybe (maybeToList)
import Safe (atMay, headMay)
import Text.Parsec
import Text.Parsec.String (Parser)

data ElemSpec
    = ESNum Int
    | ESSearch String
    deriving (Eq,Ord,Show)

data ElemsSpec
    = EsSElemSpec ElemSpec
    | EsSRange (Maybe ElemSpec) (Maybe ElemSpec)
    | EsSSearch String
    deriving (Eq,Ord,Show)

type ElemsSpecs = [ElemsSpec]

elemsSpecsNum :: Int -> ElemsSpecs
elemsSpecsNum = (:[]) . EsSElemSpec . ESNum

resolveElemsSpecs :: String -> (String -> a -> Bool) -> [a] -> ElemsSpecs -> Either String [a]
resolveElemsSpecs typeStr match as ess =
    concat <$> mapM resolveElemsSpec ess >>= \case
        [] -> Left $ "No such " <> typeStr
        as' -> return as'
    where
    resolveElemsSpec (EsSElemSpec es) =
        maybeToList . atMay as <$> resolveES es
    resolveElemsSpec (EsSRange mes1 mes2) = do
        mns1 <- mapM resolveES mes1
        mns2 <- mapM resolveES mes2
        return $ case liftM2 (>) mns1 mns2 of
            Just True -> reverse . maybe id drop mns2 $ maybe id (take . (+ 1)) mns1 as
            _ -> maybe id drop mns1 $ maybe id (take . (+ 1)) mns2 as
    resolveElemsSpec (EsSSearch s) = return $ filter (s `match`) as

    resolveES :: ElemSpec -> Either String Int
    resolveES (ESNum n) = return $ n - 1
    resolveES (ESSearch s) =
        maybe (Left $ "No " <> typeStr <> " matches pattern: " ++ s) Right $
            headMay . map fst . filter snd . zip [0..] $ (s `match`) <$> as

data PTarget
    = PTargetCurr
    | PTargetJumpBack
    | PTargetMark String
    | PTargetAbs String
    | PTargetLog ElemsSpecs
    | PTargetQueue ElemsSpecs
    | PTargetAncestors PTarget ElemsSpecs
    | PTargetDescendants PTarget ElemsSpecs
    | PTargetChild
        { ptcIncreasing :: Bool, ptcNoVisited :: Bool
        , ptcTarget :: PTarget, ptcSpecs :: ElemsSpecs }
    | PTargetLinks
        { ptlNoVisited :: Bool
        , ptlTarget :: PTarget, ptlSpecs :: ElemsSpecs }
    | PTargetRef PTarget String
    deriving (Eq,Ord,Show)

data CommandArg = CommandArg
    { commandArgArg :: String
    , commandArgLiteralTail :: String
    } deriving (Eq,Ord,Show)

data CommandLine
    = CommandLine (Maybe PTarget) (Maybe (String,[CommandArg]))
    deriving (Eq,Ord,Show)

parseCommandLine :: String -> Either String CommandLine
parseCommandLine = first show . parse (spaces >> commandLine <* eof) ""

parseCommand :: String -> Either String String
parseCommand = first show . parse command ""

commandLine :: Parser CommandLine
commandLine = choice
    [ char '#' >> many anyChar >> return (CommandLine Nothing Nothing)
    , liftM2 CommandLine (optionMaybe target) $ spaces >> optionMaybe commandAndArgs
    ]

commandAndArgs :: Parser (String, [CommandArg])
commandAndArgs =
    liftM2 (,) command $ spaces >> commandArgs

commandArgs :: Parser [CommandArg]
commandArgs = liftM2 (flip CommandArg)
    (lookAhead $ many1 anyChar) commandArg `sepEndBy` spaces

command :: Parser String
command = choice
    [ liftM2 (:) (oneOf "|!") (many $ oneOf "|!-")
    , many1 letter ]

commandArg :: Parser String
commandArg = escapedArg

escapedArg :: Parser String
escapedArg = escapedWhile $ noneOf " "

escapedWhile :: Parser Char -> Parser String
escapedWhile c = many1 $ (char '\\' >> anyChar) <|> c

nat :: Parser Int
nat = read <$> many1 digit

countMany :: Parser String -> Parser Int
countMany s = (s >> (+ 1) <$> countMany s) <|> return 0

patt :: Parser String
patt = escapedWhile (noneOf "^ ") <* optional (char '^')

elemSpec :: Parser ElemSpec
elemSpec = choice
    [ ESNum <$> nat
    , char '^' >> ESSearch <$> patt ]

elemsSpec :: Parser ElemsSpec
elemsSpec = choice
    [ try $ string "^^" >> EsSSearch <$> patt
    , do
        mess1 <- optionMaybe elemSpec
        choice
            [ char '-' >> EsSRange mess1 <$> optionMaybe elemSpec
            , maybe mzero (return . EsSElemSpec) mess1 ]
    ]

elemsSpecs :: Parser ElemsSpecs
elemsSpecs = sepBy1 elemsSpec (char ',')

elemsSpecsBy :: Parser String -> Parser ElemsSpecs
elemsSpecsBy s = s >> choice
    [ elemsSpecs
    , elemsSpecsNum . (+ 1) <$> countMany s ]

escapedArgStartingWith :: Parser Char -> Parser String
escapedArgStartingWith p = liftM2 (:) p (escapedArg <|> return "")

ref :: String -> Parser String
ref = escapedArgStartingWith . oneOf

baseTarget :: Parser PTarget
baseTarget = choice
    [ PTargetLinks False PTargetCurr <$> elemsSpecs
    , PTargetRef PTargetCurr <$> ref "./?"
    , PTargetLog <$> elemsSpecsBy (string "$")
    , PTargetQueue <$> elemsSpecsBy (string "~")
    , char '\'' >> choice
        [ char '\'' >> return PTargetJumpBack
        , PTargetMark <$> many1 alphaNum ]
    , try $ do
        s <- escapedArgStartingWith alphaNum -- scheme required for other uris
        guard . not $ all (\c -> c `elem` "!|-" || isAlphaNum c) s
        return $ PTargetAbs s
    , return PTargetCurr ]

targetMod :: Parser (PTarget -> PTarget)
targetMod = choice
    [ flip PTargetAncestors <$> elemsSpecsBy (string "<")
    , flip PTargetDescendants <$> elemsSpecsBy (string ">")
    , flip (PTargetChild True False) <$> elemsSpecsBy (string "]")
    , flip (PTargetChild True True) <$> elemsSpecsBy (string "}")
    , flip (PTargetChild False False) <$> elemsSpecsBy (string "[")
    , flip (PTargetChild False True) <$> elemsSpecsBy (string "{")
    , optional (char '_') >> flip (PTargetLinks False) <$> elemsSpecs
    , char '*' >> flip (PTargetLinks True) <$> elemsSpecs
    , flip PTargetRef <$> ref "/?"
    ]

target :: Parser PTarget
target = do
    base <- baseTarget
    mods <- many targetMod
    guard . not $ base == PTargetCurr && null mods
    return $ foldl' (flip ($)) base mods