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 $ (char '\\' >> anyChar) <|> c
 134
 135 nat :: Parser Int
 136 nat = read <$> many1 digit
 137
 138 countMany :: Parser String -> Parser Int
 139 countMany s = (s >> (+ 1) <$> countMany s) <|> return 0
 140
 141 patt :: Parser String
 142 patt = escapedWhile (noneOf "^ ") <* optional (char '^')
 143
 144 elemSpec :: Parser ElemSpec
 145 elemSpec = choice
 146     [ ESNum <$> nat
 147     , char '$' >> ESNumFromEnd <$> choice
 148         [ nat
 149         , (+ 1) <$> countMany (string "$")
 150         ]
 151     , char '^' >> ESSearch <$> patt ]
 152
 153 elemsSpec :: Parser ElemsSpec
 154 elemsSpec = choice
 155     [ try $ string "^^" >> EsSSearch <$> patt
 156     , do
 157         mess1 <- optionMaybe elemSpec
 158         choice
 159             [ char '-' >> EsSRange mess1 <$> optionMaybe elemSpec
 160             , maybe mzero (return . EsSElemSpec) mess1 ]
 161     ]
 162
 163 elemsSpecs :: Parser ElemsSpecs
 164 elemsSpecs = sepBy1 elemsSpec (char ',')
 165
 166 elemsSpecsBy :: Parser String -> Parser ElemsSpecs
 167 elemsSpecsBy s = s >> choice
 168     [ elemsSpecs
 169     , elemsSpecsNum . (+ 1) <$> countMany s ]
 170
 171 escapedArgStartingWith :: Parser Char -> Parser String
 172 escapedArgStartingWith p = liftM2 (:) p (escapedArg <|> return "")
 173
 174 ref :: String -> Parser String
 175 ref = escapedArgStartingWith . oneOf
 176
 177 baseTarget :: Parser PTarget
 178 baseTarget = choice
 179     [ PTargetLog <$> elemsSpecsBy (string "$")
 180     , PTargetLinks False PTargetCurr <$> elemsSpecs
 181     , PTargetRef PTargetCurr <$> ref "./?"
 182     , try $ do
 183         s <- many alphaNum
 184         PTargetQueue s <$> elemsSpecsBy (string "~")
 185     , char '\'' >> choice
 186         [ char '\'' >> return PTargetJumpBack
 187         , PTargetMark <$> many1 alphaNum ]
 188     , try $ do
 189         s <- escapedArgStartingWith alphaNum -- scheme required for other uris
 190         guard . not $ all (\c -> c `elem` "!|-" || isAlphaNum c) s
 191         return $ PTargetAbs s
 192     , return PTargetCurr ]
 193
 194 targetMod :: Parser (PTarget -> PTarget)
 195 targetMod = choice
 196     [ char '@' >> return PTargetRoot
 197     , flip PTargetAncestors <$> elemsSpecsBy (string "<")
 198     , flip PTargetDescendants <$> elemsSpecsBy (string ">")
 199     , flip (PTargetChild True False) <$> elemsSpecsBy (string "]")
 200     , flip (PTargetChild True True) <$> elemsSpecsBy (string "}")
 201     , flip (PTargetChild False False) <$> elemsSpecsBy (string "[")
 202     , flip (PTargetChild False True) <$> elemsSpecsBy (string "{")
 203     , optional (char '_') >> flip (PTargetLinks False) <$> elemsSpecs
 204     , char '*' >> flip (PTargetLinks True) <$> elemsSpecs
 205     , flip PTargetRef <$> ref "/?"
 206     ]
 207
 208 target :: Parser PTarget
 209 target = do
 210     base <- baseTarget
 211     mods <- many targetMod
 212     guard . not $ base == PTargetCurr && null mods
 213     return $ foldl' (flip ($)) base mods