CommandLine.hs

   1 -- This file is part of Diohsc
   2 -- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 {-# LANGUAGE LambdaCase #-}
  12 {-# LANGUAGE Safe #-}
  13
  14 module CommandLine
  15     ( CommandLine(..)
  16     , CommandArg(..)
  17     , ElemsSpecs
  18     , PTarget(..)
  19     , parseCommandLine
  20     , parseCommand
  21     , resolveElemsSpecs
  22     ) where
  23
  24 import Control.Monad (guard, liftM2, mzero)
  25 import Data.Bifunctor (first)
  26 import Data.Char (isAlphaNum)
  27 import Data.List (foldl')
  28 import Data.Maybe (maybeToList)
  29 import Safe (atMay, headMay)
  30 import Text.Parsec
  31 import Text.Parsec.String (Parser)
  32
  33 data ElemSpec
  34     = ESNum Int
  35     | ESSearch String
  36     deriving (Eq,Ord,Show)
  37
  38 data ElemsSpec
  39     = EsSElemSpec ElemSpec
  40     | EsSRange (Maybe ElemSpec) (Maybe ElemSpec)
  41     | EsSSearch String
  42     deriving (Eq,Ord,Show)
  43
  44 type ElemsSpecs = [ElemsSpec]
  45
  46 elemsSpecsNum :: Int -> ElemsSpecs
  47 elemsSpecsNum = (:[]) . EsSElemSpec . ESNum
  48
  49 resolveElemsSpecs :: String -> (a -> String -> Bool) -> [a] -> ElemsSpecs -> Either String [a]
  50 resolveElemsSpecs typeStr match as ess =
  51     concat <$> mapM resolveElemsSpec ess >>= \case
  52         [] -> Left $ "No such " <> typeStr
  53         as' -> return as'
  54     where
  55     resolveElemsSpec (EsSElemSpec es) =
  56         maybeToList . atMay as <$> resolveES es
  57     resolveElemsSpec (EsSRange mes1 mes2) = do
  58         mns1 <- mapM resolveES mes1
  59         mns2 <- mapM resolveES mes2
  60         return $ case liftM2 (>) mns1 mns2 of
  61             Just True -> reverse . maybe id drop mns2 $ maybe id (take . (+ 1)) mns1 as
  62             _ -> maybe id drop mns1 $ maybe id (take . (+ 1)) mns2 as
  63     resolveElemsSpec (EsSSearch s) = return $ filter (`match` s) as
  64
  65     resolveES :: ElemSpec -> Either String Int
  66     resolveES (ESNum n) = return $ n - 1
  67     resolveES (ESSearch s) =
  68         maybe (Left $ "No " <> typeStr <> " matches pattern: " ++ s) Right $
  69             headMay . map fst . filter snd . zip [0..] $ (`match` s) <$> as
  70
  71 data PTarget
  72     = PTargetCurr
  73     | PTargetJumpBack
  74     | PTargetMark String
  75     | PTargetAbs String
  76     | PTargetLog ElemsSpecs
  77     | PTargetQueue ElemsSpecs
  78     | PTargetAncestors PTarget ElemsSpecs
  79     | PTargetDescendants PTarget ElemsSpecs
  80     | PTargetChild
  81         { ptcIncreasing :: Bool, ptcNoVisited :: Bool
  82         , ptcTarget :: PTarget, ptcSpecs :: ElemsSpecs }
  83     | PTargetLinks
  84         { ptlNoVisited :: Bool
  85         , ptlTarget :: PTarget, ptlSpecs :: ElemsSpecs }
  86     | PTargetRef PTarget String
  87     deriving (Eq,Ord,Show)
  88
  89 data CommandArg = CommandArg
  90     { commandArgArg :: String
  91     , commandArgLiteralTail :: String
  92     } deriving (Eq,Ord,Show)
  93
  94 data CommandLine
  95     = CommandLine (Maybe PTarget) (Maybe (String,[CommandArg]))
  96     deriving (Eq,Ord,Show)
  97
  98 parseCommandLine :: String -> Either String CommandLine
  99 parseCommandLine = first show . parse (spaces >> commandLine <* eof) ""
 100
 101 parseCommand :: String -> Either String String
 102 parseCommand = first show . parse command ""
 103
 104 commandLine :: Parser CommandLine
 105 commandLine = choice
 106     [ char '#' >> many anyChar >> return (CommandLine Nothing Nothing)
 107     , liftM2 CommandLine (optionMaybe target) . optionMaybe $ spaces >> commandAndArgs
 108     ]
 109
 110 commandAndArgs :: Parser (String, [CommandArg])
 111 commandAndArgs =
 112     liftM2 (,) command $ spaces >> commandArgs
 113
 114 commandArgs :: Parser [CommandArg]
 115 commandArgs = liftM2 (flip CommandArg)
 116     (lookAhead $ many1 anyChar) commandArg `sepEndBy` spaces
 117
 118 command :: Parser String
 119 command = choice
 120     [ many1 $ oneOf "|!"
 121     , many1 letter ]
 122
 123 commandArg :: Parser String
 124 commandArg = escapedArg
 125
 126 escapedArg :: Parser String
 127 escapedArg = escapedWhile $ noneOf " "
 128
 129 escapedWhile :: Parser Char -> Parser String
 130 escapedWhile c = many1 $ (char '\\' >> anyChar) <|> c
 131
 132 nat :: Parser Int
 133 nat = read <$> many1 digit
 134
 135 countMany :: Parser String -> Parser Int
 136 countMany s = (s >> (+ 1) <$> countMany s) <|> return 0
 137
 138 patt :: Parser String
 139 patt = escapedWhile (noneOf "^ ") <* optional (char '^')
 140
 141 elemSpec :: Parser ElemSpec
 142 elemSpec = choice
 143     [ ESNum <$> nat
 144     , char '^' >> ESSearch <$> patt ]
 145
 146 elemsSpec :: Parser ElemsSpec
 147 elemsSpec = choice
 148     [ try $ string "^^" >> EsSSearch <$> patt
 149     , do
 150         mess1 <- optionMaybe elemSpec
 151         choice
 152             [ char '-' >> EsSRange mess1 <$> optionMaybe elemSpec
 153             , maybe mzero (return . EsSElemSpec) mess1 ]
 154     ]
 155
 156 elemsSpecs :: Parser ElemsSpecs
 157 elemsSpecs = sepBy1 elemsSpec (char ',')
 158
 159 elemsSpecsBy :: Parser String -> Parser ElemsSpecs
 160 elemsSpecsBy s = s >> choice
 161     [ elemsSpecs
 162     , elemsSpecsNum . (+ 1) <$> countMany s ]
 163
 164 escapedArgStartingWith :: Parser Char -> Parser String
 165 escapedArgStartingWith p = liftM2 (:) p (escapedArg <|> return "")
 166
 167 ref :: String -> Parser String
 168 ref = escapedArgStartingWith . oneOf
 169
 170 baseTarget :: Parser PTarget
 171 baseTarget = choice
 172     [ PTargetLinks False PTargetCurr <$> elemsSpecs
 173     , PTargetRef PTargetCurr <$> ref "./?"
 174     , PTargetLog <$> elemsSpecsBy (string "$")
 175     , PTargetQueue <$> elemsSpecsBy (string "~")
 176     , char '\'' >> choice
 177         [ char '\'' >> return PTargetJumpBack
 178         , PTargetMark <$> many1 alphaNum ]
 179     , try $ do
 180         s <- escapedArgStartingWith alphaNum -- scheme required for other uris
 181         guard . not $ all (\c -> c `elem` "!|" || isAlphaNum c) s
 182         return $ PTargetAbs s
 183     , return PTargetCurr ]
 184
 185 targetMod :: Parser (PTarget -> PTarget)
 186 targetMod = choice
 187     [ flip PTargetAncestors <$> elemsSpecsBy (string "<")
 188     , flip PTargetDescendants <$> elemsSpecsBy (string ">")
 189     , flip (PTargetChild True False) <$> elemsSpecsBy (string "]")
 190     , flip (PTargetChild True True) <$> elemsSpecsBy (string "}")
 191     , flip (PTargetChild False False) <$> elemsSpecsBy (string "[")
 192     , flip (PTargetChild False True) <$> elemsSpecsBy (string "{")
 193     , optional (char '_') >> flip (PTargetLinks False) <$> elemsSpecs
 194     , char '*' >> flip (PTargetLinks True) <$> elemsSpecs
 195     , flip PTargetRef <$> ref "/?"
 196     ]
 197
 198 target :: Parser PTarget
 199 target = do
 200     base <- baseTarget
 201     mods <- many targetMod
 202     guard . not $ base == PTargetCurr && null mods
 203     return $ foldl' (flip ($)) base mods