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     | ESNumFromEnd Int
  36     | ESSearch String
  37     deriving (Eq,Ord,Show)
  38
  39 data ElemsSpec
  40     = EsSElemSpec ElemSpec
  41     | EsSRange (Maybe ElemSpec) (Maybe ElemSpec)
  42     | EsSSearch String
  43     deriving (Eq,Ord,Show)
  44
  45 type ElemsSpecs = [ElemsSpec]
  46
  47 elemsSpecsNum :: Int -> ElemsSpecs
  48 elemsSpecsNum = (:[]) . EsSElemSpec . ESNum
  49
  50 resolveElemsSpecs :: String -> (String -> a -> Bool) -> [a] -> ElemsSpecs -> Either String [a]
  51 resolveElemsSpecs typeStr match as ess =
  52     mapM resolveElemsSpec ess >>= (\case
  53         []  -> Left $ "No such " <> typeStr
  54         as' -> return as') . concat
  55     where
  56     resolveElemsSpec (EsSElemSpec es) =
  57         maybeToList . atMay as <$> resolveES es
  58     resolveElemsSpec (EsSRange mes1 mes2) = do
  59         mns1 <- mapM resolveES mes1
  60         mns2 <- mapM resolveES mes2
  61         return $ if Just True == liftM2 (>) mns1 mns2 || mns2 == Just (-1)
  62             then reverse . maybe id drop mns2 $ maybe id (take . (+ 1)) mns1 as
  63             else maybe id drop mns1 $ maybe id (take . (+ 1)) mns2 as
  64     resolveElemsSpec (EsSSearch s) = return $ filter (s `match`) as
  65
  66     resolveES :: ElemSpec -> Either String Int
  67     resolveES (ESNum n) = return $ n - 1
  68     resolveES (ESNumFromEnd n) = return $ length as - n
  69     resolveES (ESSearch s) =
  70         maybe (Left $ "No " <> typeStr <> " matches pattern: " ++ s) Right $
  71             headMay . map fst . filter snd . zip [0..] $ (s `match`) <$> as
  72
  73 data PTarget
  74     = PTargetCurr
  75     | PTargetJumpBack
  76     | PTargetMark String
  77     | PTargetAbs String
  78     | PTargetLog ElemsSpecs
  79     | PTargetQueue String ElemsSpecs
  80     | PTargetRoot PTarget
  81     | PTargetAncestors PTarget ElemsSpecs
  82     | PTargetDescendants PTarget ElemsSpecs
  83     | PTargetChild
  84         { ptcIncreasing :: Bool, ptcNoVisited :: Bool
  85         , ptcTarget :: PTarget, ptcSpecs :: ElemsSpecs }
  86     | PTargetLinks
  87         { ptlNoVisited :: Bool
  88         , ptlTarget :: PTarget, ptlSpecs :: ElemsSpecs }
  89     | PTargetRef PTarget String
  90     deriving (Eq,Ord,Show)
  91
  92 data CommandArg = CommandArg
  93     { commandArgArg         :: String
  94     , commandArgLiteralTail :: String
  95     } deriving (Eq,Ord,Show)
  96
  97 data CommandLine
  98     = CommandLine (Maybe PTarget) (Maybe (String,[CommandArg]))
  99     deriving (Eq,Ord,Show)
 100
 101 parseCommandLine :: String -> Either String CommandLine
 102 parseCommandLine = first show . parse (spaces >> commandLine <* eof) ""
 103
 104 parseCommand :: String -> Either String String
 105 parseCommand = first show . parse command ""
 106
 107 commandLine :: Parser CommandLine
 108 commandLine = choice
 109     [ char '#' >> many anyChar >> return (CommandLine Nothing Nothing)
 110     , liftM2 CommandLine (optionMaybe target) $ spaces >> optionMaybe commandAndArgs
 111     ]
 112
 113 commandAndArgs :: Parser (String, [CommandArg])
 114 commandAndArgs =
 115     liftM2 (,) command $ spaces >> commandArgs
 116
 117 commandArgs :: Parser [CommandArg]
 118 commandArgs = liftM2 (flip CommandArg)
 119     (lookAhead $ many1 anyChar) commandArg `sepEndBy` spaces
 120
 121 command :: Parser String
 122 command = choice
 123     [ liftM2 (:) (oneOf "|!") (many $ oneOf "|!-")
 124     , many1 letter ]
 125
 126 commandArg :: Parser String
 127 commandArg = escapedArg
 128
 129 escapedArg :: Parser String
 130 escapedArg = escapedWhile $ noneOf " "
 131
 132 escapedWhile :: Parser Char -> Parser String
 133 escapedWhile c = many1 $
 134     -- Allow escaping chars with \\, but preserve terminal \\
 135     (char '\\' >> (anyChar <|> (eof >> pure '\\'))) <|> c
 136
 137 nat :: Parser Int
 138 nat = read <$> many1 digit
 139
 140 countMany :: Parser String -> Parser Int
 141 countMany s = (s >> (+ 1) <$> countMany s) <|> return 0
 142
 143 patt :: Parser String
 144 patt = escapedWhile (noneOf "^ ") <* optional (char '^')
 145
 146 elemSpec :: Parser ElemSpec
 147 elemSpec = choice
 148     [ ESNum <$> nat
 149     , char '$' >> ESNumFromEnd <$> choice
 150         [ nat
 151         , (+ 1) <$> countMany (string "$")
 152         ]
 153     , char '^' >> ESSearch <$> patt ]
 154
 155 elemsSpec :: Parser ElemsSpec
 156 elemsSpec = choice
 157     [ try $ string "^^" >> EsSSearch <$> patt
 158     , do
 159         mess1 <- optionMaybe elemSpec
 160         choice
 161             [ char '-' >> EsSRange mess1 <$> optionMaybe elemSpec
 162             , maybe mzero (return . EsSElemSpec) mess1 ]
 163     ]
 164
 165 elemsSpecs :: Parser ElemsSpecs
 166 elemsSpecs = sepBy1 elemsSpec (char ',')
 167
 168 elemsSpecsBy :: Parser String -> Parser ElemsSpecs
 169 elemsSpecsBy s = s >> choice
 170     [ elemsSpecs
 171     , elemsSpecsNum . (+ 1) <$> countMany s ]
 172
 173 escapedArgStartingWith :: Parser Char -> Parser String
 174 escapedArgStartingWith p = liftM2 (:) p (escapedArg <|> return "")
 175
 176 ref :: String -> Parser String
 177 ref = escapedArgStartingWith . oneOf
 178
 179 baseTarget :: Parser PTarget
 180 baseTarget = choice
 181     [ PTargetLog <$> elemsSpecsBy (string "$")
 182     , PTargetLinks False PTargetCurr <$> elemsSpecs
 183     , PTargetRef PTargetCurr <$> ref "./?"
 184     , try $ do
 185         s <- many alphaNum
 186         PTargetQueue s <$> elemsSpecsBy (string "~")
 187     , char '\'' >> choice
 188         [ char '\'' >> return PTargetJumpBack
 189         , PTargetMark <$> many1 alphaNum ]
 190     , try $ do
 191         s <- escapedArgStartingWith alphaNum -- scheme required for other uris
 192         guard . not $ all (\c -> c `elem` "!|-" || isAlphaNum c) s
 193         return $ PTargetAbs s
 194     , return PTargetCurr ]
 195
 196 targetMod :: Parser (PTarget -> PTarget)
 197 targetMod = choice
 198     [ char '@' >> return PTargetRoot
 199     , flip PTargetAncestors <$> elemsSpecsBy (string "<")
 200     , flip PTargetDescendants <$> elemsSpecsBy (string ">")
 201     , flip (PTargetChild True False) <$> elemsSpecsBy (string "]")
 202     , flip (PTargetChild True True) <$> elemsSpecsBy (string "}")
 203     , flip (PTargetChild False False) <$> elemsSpecsBy (string "[")
 204     , flip (PTargetChild False True) <$> elemsSpecsBy (string "{")
 205     , optional (char '_') >> flip (PTargetLinks False) <$> elemsSpecs
 206     , char '*' >> flip (PTargetLinks True) <$> elemsSpecs
 207     , flip PTargetRef <$> ref "/?"
 208     ]
 209
 210 target :: Parser PTarget
 211 target = do
 212     base <- baseTarget
 213     mods <- many targetMod
 214     guard . not $ base == PTargetCurr && null mods
 215     return $ foldl' (flip ($)) base mods