smh (empty) → 0.1.3
raw patch · 10 files changed
+1680/−0 lines, 10 filesdep +arraydep +basedep +extra
Dependencies added: array, base, extra, lens, loop, megaparsec, process, regex-pcre-builtin, scientific, tasty, tasty-hunit, text
Files
- CHANGELOG.md +19/−0
- LICENSE +20/−0
- app/Main.hs +55/−0
- smh.cabal +64/−0
- src/Actions.hs +64/−0
- src/Common.hs +166/−0
- src/Focusers.hs +455/−0
- src/Mappings.hs +122/−0
- src/Parsers.hs +388/−0
- test/Main.hs +327/−0
+ CHANGELOG.md view
@@ -0,0 +1,19 @@+# Revision history for smh++## 0.1.0 -- 2024-02-18++* First version. Released on an unsuspecting world.++## 0.1.1 -- 2024-02-28++* Changed mapping separator from ">" to ":".++## 0.1.2 -- 2024-03-02++* added --version option++## 0.1.3 -- 2024-03-03++* made slicing more flexible (you can now change the length of the focused segment)++* made regex user perl style instead of POSIX style
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2024 dani-rybe++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ app/Main.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE ImpredicativeTypes #-}+{-# OPTIONS_GHC -Wno-unused-do-bind #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Actions (parseAction)+import Common (Action, Focuser, Parser, foldFocusers,+ symbol)+import Control.Monad (when)+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import Data.Version (showVersion)+import Parsers (parseFocusers)+import Paths_smh (version)+import System.Environment (getArgs)+import System.Exit (exitFailure, exitSuccess)+import Text.Megaparsec (errorBundlePretty, many, optional, parse)+import Text.Megaparsec.Char (char)++main :: IO ()+main = do+ args <- getArgs++ when (args == ["--version"]) $ do+ putStrLn ("smh " ++ showVersion version)+ exitSuccess++ when (length args /= 1 && length args /= 2) $ do+ putStrLn "usage: smh <command> [input]"+ exitFailure++ (focusers, action) <- case parse parseData "input" (T.pack $ head args) of+ Left errors -> do+ putStrLn $ errorBundlePretty errors+ exitFailure+ Right x -> pure x++ let focuser = foldFocusers focusers+ input <- if length args == 1+ then TIO.getContents+ else return $ T.pack $ args !! 1+ action input focuser+++parseData :: Parser ([Focuser], Action)+parseData = do+ many (char ' ')+ focusers <- fromMaybe [] <$> optional parseFocusers+ symbol "|"+ action <- parseAction+ return (focusers, action)++
+ smh.cabal view
@@ -0,0 +1,64 @@+cabal-version: 3.0+name: smh+version: 0.1.3+synopsis: String manipulation tool written in haskell+description: String manipulation CLI tool based on optics+category: CLI Tool+license: MIT+license-file: LICENSE+author: dani-rybe+maintainer: danilrybakov249@gmail.com+-- copyright:+build-type: Simple+extra-doc-files: CHANGELOG.md+-- extra-source-files:+source-repository head+ type: git+ location: https://github.com/DanRyba253/smh.git++common warnings+ ghc-options: -Wall++executable smh+ import: warnings+ main-is: Main.hs+ other-modules: Paths_smh+ autogen-modules: Paths_smh+ build-depends: base ^>=4.17.2.1,+ megaparsec >= 9.6.1 && < 9.7,+ text >= 2.0.2 && < 2.1,+ hs-source-dirs: app+ default-language: Haskell2010++library lib+ exposed-modules: Actions,+ Common,+ Focusers,+ Mappings,+ Parsers+ build-depends: base ^>=4.17.2.1,+ megaparsec >= 9.6.1 && < 9.7,+ lens >= 5.2.3 && < 5.3,+ scientific >= 0.3.7 && < 0.4,+ text >= 2.0.2 && < 2.1,+ array >= 0.5.4 && < 0.6,+ extra >= 1.7.14 && < 1.8,+ regex-pcre-builtin >= 0.95.2 && < 0.96,+ loop >= 0.3.0 && < 0.4+ hs-source-dirs: src+ default-language: Haskell2010++test-suite unit-test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends: base ^>=4.17.2.1,+ tasty,+ tasty-hunit,+ process,+ extra >= 1.7.14 && < 1.8,+ scientific >= 0.3.7 && < 0.4,+ text >= 2.0.2 && < 2.1+ default-language: Haskell2010+
+ src/Actions.hs view
@@ -0,0 +1,64 @@+{-# OPTIONS_GHC -Wno-unused-do-bind #-}+{-# LANGUAGE OverloadedStrings #-}++module Actions where++import Common (Action, Focus (FList, FText),+ Focuser (FTrav), Mapping, Parser,+ foldMappings, lexeme, symbol,+ toTextUnsafe)+import Control.Lens ((%~), (&), (.~), (^..))+import Control.Lens.Extras (biplate)+import Data.Char (isAlphaNum)+import Data.Functor (($>))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import Parsers (parseMappings, stringLiteral)+import Text.Megaparsec (MonadParsec (label, notFollowedBy),+ choice, satisfy)+import Text.Megaparsec.Char (string)++parseAction :: Parser Action+parseAction = label "valid action" $ choice+ [ symbol "get-tree" $> getTree+ , symbol "get" $> actionGet+ , parseActionOver+ , parseActionSet+ ]++actionGet :: Action+actionGet input (FTrav trav) = do+ let focus = FList $ FText input ^.. trav+ printFocus focus+ where+ printFocus (FText str) = TIO.putStrLn str+ printFocus (FList lst) = mapM_ printFocus lst++actionOver :: Mapping -> Action+actionOver mapping input (FTrav trav) = do+ let output = toTextUnsafe $ FText input & trav %~ mapping+ TIO.putStr output++parseActionOver :: Parser Action+parseActionOver = do+ lexeme $ string "over" >> notFollowedBy (satisfy isAlphaNum)+ mappings <- parseMappings+ let mapping = foldMappings mappings+ return $ actionOver mapping++actionSet :: Text -> Action+actionSet str input (FTrav trav) = do+ let output = toTextUnsafe $ FText input & trav . biplate .~ str+ TIO.putStrLn output++parseActionSet :: Parser Action+parseActionSet = do+ symbol "set"+ actionSet <$> stringLiteral++getTree :: Action+getTree input (FTrav trav) = do+ putStr $ show $ FText input ^.. trav++
+ src/Common.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}++module Common(module Common) where++import Control.Applicative (empty)+import Control.Lens (Lens', Traversal', lens, (^..))+import Control.Loop (numLoop)+import Control.Monad (forM_)+import Control.Monad.ST.Strict (ST, runST)+import Data.Array.ST (STUArray)+import qualified Data.Array.ST as A+import Data.Data (Data)+import Data.List (nub, sort)+import Data.List.Extra (nubOrd)+import Data.Scientific (Scientific, floatingOrInteger,+ fromFloatDigits, toRealFloat)+import Data.STRef ()+import Data.Text (Text)+import qualified Data.Text as T+import Data.Void (Void)+import Text.Megaparsec (Parsec, label)+import Text.Megaparsec.Char (space1)+import qualified Text.Megaparsec.Char.Lexer as L++data Focus+ = FText !Text+ | FList ![Focus]+ deriving Data++instance Show Focus where+ show (FText str) = show str+ show (FList lst) = show lst++instance Eq Focus where+ (FText str1) == (FText str2) = str1 == str2+ (FList lst1) == (FList lst2) = lst1 == lst2+ _ == _ = False++toTextUnsafe :: Focus -> Text+toTextUnsafe (FText str) = str+toTextUnsafe _ = error "toText called on a non-FText"++toListUnsafe :: Focus -> [Focus]+toListUnsafe (FList lst) = lst+toListUnsafe _ = error "toList called on a non-FText"++_toListUnsafe :: Lens' [Focus] Focus+_toListUnsafe = lens FList $ const toListUnsafe++newtype Focuser = FTrav (Traversal' Focus Focus)++composeFocusers :: Focuser -> Focuser -> Focuser+composeFocusers (FTrav a) (FTrav b) = FTrav (a . b)++foldFocusers :: [Focuser] -> Focuser+foldFocusers = foldr composeFocusers (FTrav id)++type Action = Text -> Focuser -> IO ()++type Mapping = Focus -> Focus++foldMappings :: [Mapping] -> Mapping+foldMappings = foldr (flip (.)) id++type Parser = Parsec Void Text++showScientific :: Scientific -> Text+showScientific n = case floatingOrInteger n :: Either Double Int of+ Left d -> T.pack $ show d+ Right i -> T.pack $ show i++safeDiv :: Scientific -> Scientific -> Scientific+safeDiv a b = fromFloatDigits (toRealFloat a / toRealFloat b)++data Range+ = RangeSingle !Int+ | RangeRange !(Maybe Int) !(Maybe Int)++getIndexes :: [Range] -> Int -> [Int]+getIndexes ranges len = nubOrd . sort . concatMap (getIndexes' . fixRange) $ ranges+ where+ getIndexes' (RangeSingle i) = [i]+ getIndexes' (RangeRange mstart mend) =+ case (mstart, mend) of+ (Just start, Just end) -> [start .. end - 1]+ (Just start, Nothing) -> [start .. len - 1]+ (Nothing, Just end) -> [0 .. end - 1]+ (Nothing, Nothing) -> [0 .. len - 1]++ fixRange (RangeSingle i) = RangeSingle (fixIndex i)+ fixRange (RangeRange mstart mend) = RangeRange+ (fixIndex <$> mstart) (fixIndex <$> mend)++ fixIndex i+ | i < 0 = max (i + len) 0+ | otherwise = min i len+++data Evaluatable+ = EText !Text+ | ENumber !Scientific+ | EFocuser { evalFocuserUnsafe :: !Focuser }++data IfExpr+ = IfAnd ![IfExpr]+ | IfOr ![IfExpr]+ | IfSingle !Comparison++data Comparison = Comparison+ { cmpLHS :: !(Quantor, Evaluatable)+ , cmpOp :: !Oper+ , cmpRHS :: !(Quantor, Evaluatable)+ }++data Quantor = QAll | QAny++data Oper+ = OpEq+ | OpNe+ | OpLt+ | OpLe+ | OpGt+ | OpGe++ws :: Parser ()+ws = L.space space1 empty empty++symbol :: Text -> Parser Text+symbol = L.symbol ws++lexeme :: Parser a -> Parser a+lexeme = L.lexeme ws++integer :: Parser Int+integer = label "integer" $ lexeme $ L.signed ws L.decimal++scient :: Parser Scientific+scient = label "number" $ lexeme $ L.signed ws L.scientific++mapText :: (Char -> a) -> Text -> [a]+mapText f = T.foldr (\c cs -> f c : cs) []++unsort :: [Int] -> Int -> [Int]+unsort is isLen = runST $ do+ is' <- A.newListArray (0, isLen - 1) is :: ST s (STUArray s Int Int)+ is'' <- A.newArray (0, isLen - 1) 0 :: ST s (STUArray s Int Int)+ numLoop 0 (isLen - 1) $ \i -> do+ j <- A.readArray is' i+ A.writeArray is'' j i+ return []++makeFilteredText :: Int -> [Int] -> Text -> Text+makeFilteredText maxLen is str = T.unfoldrN maxLen builder (0, is)+ where+ builder :: (Int, [Int]) -> Maybe (Char, (Int, [Int]))+ builder (_, []) = Nothing+ builder (n, i : is) = Just (T.index str i, (n + 1, is))++focusTo :: Mapping -> Focuser+focusTo mapping = FTrav $ lens mapping const++mappingTo :: Focuser -> Mapping+mappingTo (FTrav trav) focus = case (focus, focus ^.. trav) of+ (FText _, [FText str]) -> FText str+ _ -> focus
+ src/Focusers.hs view
@@ -0,0 +1,455 @@+{-# OPTIONS_GHC -Wno-unused-do-bind #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}++module Focusers where++import Common (Comparison (..), Evaluatable (..),+ Focus (..), Focuser (..), IfExpr (..),+ Mapping, Oper (..), Quantor (..),+ Range (RangeSingle), _toListUnsafe,+ composeFocusers, getIndexes,+ makeFilteredText, mapText, safeDiv,+ showScientific, toListUnsafe,+ toTextUnsafe, unsort)+import Control.Lens (lens, partsOf, (^..))+import Data.Char (isAlpha, isAlphaNum, isDigit, isLower,+ isSpace, isUpper)+import Data.Data.Lens (biplate)+import Data.Function (on)+import Data.Functor ((<&>))+import Data.List (sortBy, transpose)+import Data.Maybe (mapMaybe)+import Data.Ord (comparing)+import Data.Scientific (Scientific)+import Data.Text (Text)+import qualified Data.Text as T+import Text.Read (readMaybe)+import Text.Regex.PCRE (AllMatches (getAllMatches), (=~))+import Text.Regex.PCRE.Text ()++focusId :: Focuser+focusId = FTrav id++focusEach :: Focuser+focusEach = FTrav traverseFocus++traverseFocus :: Applicative f => (Focus -> f Focus) -> (Focus -> f Focus)+traverseFocus f focus = case focus of+ FText str -> FText . T.concat . map toTextUnsafe <$> traverse f (mapText (FText . T.singleton) str)+ FList lst -> FList <$> traverse f lst++focusCollect :: Focuser -> Focuser+focusCollect (FTrav innerTrav) = FTrav $ partsOf innerTrav . _toListUnsafe++focusWords :: Focuser+focusWords = FTrav wordsTrav++wordsTrav :: Applicative f => (Focus -> f Focus) -> (Focus -> f Focus)+wordsTrav _ flst@(FList _) = pure flst+wordsTrav f (FText str) =+ let (str_ws, str_words) = myWords str+ new_words = map toTextUnsafe <$> traverse (f . FText) str_words+ new_str = T.concat . interleave str_ws <$> new_words+ in FText <$> new_str++myWords :: Text -> ([Text], [Text])+myWords "" = ([], [])+myWords str =+ let (ws, str') = T.span isSpace str+ (word, str'') = T.break isSpace str'+ (str_ws, str_words) = myWords str''+ in (ws : str_ws, if not (T.null word) then word : str_words else str_words)++focusSpace :: Focuser+focusSpace = FTrav spaceTrav++spaceTrav :: Applicative f => (Focus -> f Focus) -> (Focus -> f Focus)+spaceTrav _ flst@(FList _) = pure flst+spaceTrav f (FText str) =+ let (str_nonspace, str_space) = mySpace str+ new_space = map toTextUnsafe <$> traverse (f . FText) str_space+ new_str = T.concat . interleave str_nonspace <$> new_space+ in FText <$> new_str++mySpace :: Text -> ([Text], [Text])+mySpace "" = ([], [])+mySpace str =+ let (nonspace, str') = T.break isSpace str+ (space, str'') = T.span isSpace str'+ (str_nonspace, str_space) = mySpace str''+ in (nonspace : str_nonspace, if not (T.null space) then space : str_space else str_space)++interleave :: [a] -> [a] -> [a]+interleave [] a2s = a2s+interleave a1s [] = a1s+interleave (a1 : a1s) (a2 : a2s) = a1 : a2 : interleave a1s a2s++focusLines :: Focuser+focusLines = FTrav linesTrav++linesTrav :: Applicative f => (Focus -> f Focus) -> (Focus -> f Focus)+linesTrav _ flst@(FList _) = pure flst+linesTrav f (FText str) = FText . T.concat . map ((`T.append` "\n") . toTextUnsafe)+ <$> traverse (f . FText) (T.lines str)++transposeTravUnsafe :: Applicative f => (Focus -> f Focus) -> (Focus -> f Focus)+transposeTravUnsafe f flist = transposeFListUnsafe <$> f (transposeFListUnsafe flist)++transposeFListUnsafe :: Focus -> Focus+transposeFListUnsafe (FList lst) = FList . map FList $ transpose (toListUnsafe <$> lst)+transposeFListUnsafe _ =+ error "smh: transposeFListUnsafe called on a non-FList. Please, report this bug."++focusCols :: Focuser+focusCols = focusCollect (focusLines `composeFocusers` focusCollect focusWords)+ `composeFocusers` FTrav transposeTravUnsafe+ `composeFocusers` focusEach++focusSlice :: [Range] -> Focuser+focusSlice ranges = FTrav $ \f focus -> case focus of+ FText str -> FText <$> new_str+ where+ str_length = T.length str+ is = getIndexes ranges str_length+ filtered_str = makeFilteredText str_length is str+ new_filtered_str = toTextUnsafe <$> (f . FText $ filtered_str)+ new_str = updateText str is <$> new_filtered_str++ FList lst -> FList <$> new_lst+ where+ is = getIndexes ranges (length lst)+ filtered_lst = makeFilteredList is 0 lst+ new_filtered_list = toListUnsafe <$> (f . FList $ filtered_lst)+ new_lst = updateList lst . zip is <$> new_filtered_list+ where+ makeFilteredList [] _ _ = []+ makeFilteredList _ _ [] = []+ makeFilteredList (i : is) idx (c : str)+ | idx == i = c : makeFilteredList is (idx + 1) str+ | otherwise = makeFilteredList (i : is) (idx + 1) str++ updateList :: [a] -> [(Int, a)] -> [a]+ updateList as updates = aux (zip [0..] as) updates+ where+ aux old [] = map snd old+ aux [] _ = []+ aux ((i, a) : old) ((j, a') : updates)+ | i == j = a' : aux old updates+ | otherwise = a : aux old ((j, a') : updates)++ updateText :: Text -> [Int] -> Text -> Text+ updateText old is new = T.unfoldrN (oldLen + newLen) builder (0, 0, is)+ where+ newLen = T.length new+ oldLen = T.length old++ builder :: (Int, Int, [Int]) -> Maybe (Char, (Int, Int, [Int]))+ builder (oldI, newI, [])+ | newI < newLen = Just (T.index new newI, (oldI, newI + 1, []))+ | oldI < oldLen = Just (T.index old oldI, (oldI + 1, newI, []))+ | otherwise = Nothing+ builder (oldI, newI, i : is)+ | oldI == i = if newI < newLen+ then Just (T.index new newI, (oldI + 1, newI + 1, is))+ else builder (oldI + 1, newI + 1, is)+ | otherwise = Just (T.index old oldI, (oldI + 1, newI, i : is))++focusSortedBy :: Focuser -> Focuser+focusSortedBy (FTrav trav) = FTrav $ \f focus -> case focus of+ FText str ->+ let str_length = T.length str+ (is, sorted_str) = unzip $ sortBy (cmp `on` (FText . T.singleton . snd)) $+ zip [0..] $ T.unpack str+ new_sorted_str = toTextUnsafe <$> (f . FText) ( T.pack sorted_str)+ unsort_is = unsort is str_length+ new_str = unsortText unsort_is str_length <$> new_sorted_str+ in FText <$> new_str+ FList lst ->+ let (is, sorted_lst) = unzip $ sortBy (cmp `on` snd) $ zip [0..] lst+ new_sorted_lst = toListUnsafe <$> (f . FList) sorted_lst+ new_lst = map snd . sortBy (comparing fst) . zip is <$> new_sorted_lst+ in FList <$> new_lst+ where+ cmp f1 f2 =+ let f1' = f1 ^.. trav+ f2' = f2 ^.. trav+ in case (f1', f2') of+ ([FText s1], [FText s2]) -> case (readMDouble s1, readMDouble s2) of+ (Just n1, Just n2) -> compare n1 n2+ _ -> EQ+ _ -> EQ++ unsortText :: [Int] -> Int -> Text -> Text+ unsortText is strLen str = T.unfoldrN strLen builder is+ where+ builder :: [Int] -> Maybe (Char, [Int])+ builder [] = Nothing+ builder (i : is) = Just (T.index str i, is)+++ readMDouble :: Text -> Maybe Double+ readMDouble = readMaybe . T.unpack++focusIndex :: Int -> Focuser+focusIndex n_ = FTrav $ \f focus -> case focus of+ FText str -> if n < 0 || n >= T.length str then pure focus else+ (f . FText . T.singleton) (T.index str n) <&> \new_str ->+ case toTextUnsafe new_str of+ "" -> FText str+ text -> FText $ updateTextAt str_length str n (T.head text)+ where+ str_length = T.length str+ n = if n_ < 0 then str_length + n_ else n_+ FList lst -> if n < 0 || n >= length lst then pure focus else+ let new_focus = f (lst !! n)+ in FList . updateListAt lst n <$> new_focus+ where+ n = if n_ < 0 then length lst + n_ else n_+ where+ updateListAt :: [a] -> Int -> a -> [a]+ updateListAt [] _ _ = []+ updateListAt (_ : olds) 0 a = a : olds+ updateListAt (o : olds) n a = o : updateListAt olds (n - 1) a++ updateTextAt :: Int -> Text -> Int -> Char -> Text+ updateTextAt strLen str i newC = T.unfoldrN strLen builder 0+ where+ builder :: Int -> Maybe (Char, Int)+ builder n+ | n >= strLen = Nothing+ | n == i = Just (newC, n + 1)+ | otherwise = Just (T.index str n, n + 1)++focusMinBy :: Focuser -> Focuser+focusMinBy f = focusSortedBy f `composeFocusers` focusIndex 0++focusMaxBy :: Focuser -> Focuser+focusMaxBy f = focusSortedBy f `composeFocusers` focusIndex (-1)++focusSortedLexBy :: Focuser -> Focuser+focusSortedLexBy (FTrav trav) = FTrav $ \f focus -> case focus of+ FText str ->+ let (is, sorted_str) = unzip $ sortBy (cmp `on` (FText . T.singleton . snd)) $+ zip [0..] $ T.unpack str+ str_length = T.length str+ new_sorted_str = toTextUnsafe <$> (f . FText . T.pack) sorted_str+ unsort_is = unsort is str_length+ new_str = unsortText unsort_is str_length <$> new_sorted_str+ in FText <$> new_str+ FList lst ->+ let (is, sorted_lst) = unzip $ sortBy (cmp `on` snd) $ zip [0..] lst+ new_sorted_lst = toListUnsafe <$> (f . FList) sorted_lst+ new_lst = map snd . sortBy (comparing fst) . zip is <$> new_sorted_lst+ in FList <$> new_lst+ where+ cmp f1 f2 =+ let f1' = f1 ^.. trav+ f2' = f2 ^.. trav+ in case (f1', f2') of+ ([FText s1], [FText s2]) -> compare s1 s2+ _ -> EQ++ unsortText :: [Int] -> Int -> Text -> Text+ unsortText is strLen str = T.unfoldrN strLen builder is+ where+ builder :: [Int] -> Maybe (Char, [Int])+ builder [] = Nothing+ builder (i : is) = Just (T.index str i, is)++focusMinLexBy :: Focuser -> Focuser+focusMinLexBy f = focusSortedLexBy f `composeFocusers` focusIndex 0++focusMaxLexBy :: Focuser -> Focuser+focusMaxLexBy f = focusSortedLexBy f `composeFocusers` focusIndex (-1)++focusSum :: Focuser+focusSum = FTrav $ lens getSum const++getSum :: Focus -> Focus+getSum focus = case focus of+ FList _ -> FText $ showScientific $ sum $+ mapMaybe readMaybeScientific $ focus ^.. biplate+ FText s -> FText $ showScientific $ sum $+ mapMaybe (readMaybeScientific . T.singleton) $ T.unpack s++focusProduct :: Focuser+focusProduct = FTrav $ lens getProduct const++getProduct :: Focus -> Focus+getProduct focus = case focus of+ FList _ -> FText $ showScientific $ product $+ mapMaybe readMaybeScientific $ focus ^.. biplate+ FText s -> FText $ showScientific $ product $+ mapMaybe (readMaybeScientific . T.singleton) $ T.unpack s++focusAverage :: Scientific -> Focuser+focusAverage n = FTrav $ lens (getAverage n) const++getAverage :: Scientific -> Focus -> Focus+getAverage n focus = case focus of+ FList _ -> FText $ showScientific $ average n $+ mapMaybe readMaybeScientific $ focus ^.. biplate+ FText s -> FText $ showScientific $ average n $+ mapMaybe (readMaybeScientific . T.singleton) $ T.unpack s++average :: Scientific -> [Scientific] -> Scientific+average n [] = n+average _ xs = sum xs / fromIntegral (length xs)++readMaybeScientific :: Text -> Maybe Scientific+readMaybeScientific = readMaybe . T.unpack++focusIf :: IfExpr -> Focuser+focusIf ifexpr = FTrav $ \f focus -> if focus `passesIf` ifexpr+ then f focus+ else pure focus+ where+ passesIf :: Focus -> IfExpr -> Bool+ passesIf focus (IfAnd ifexprs) = all (passesIf focus) ifexprs+ passesIf focus (IfOr ifexprs) = any (passesIf focus) ifexprs+ passesIf focus (IfSingle comp) =+ let op = cmpOp comp+ q1 = fst $ cmpLHS comp+ q2 = fst $ cmpRHS comp+ f1s = evaluateEval focus $ snd $ cmpLHS comp+ f2s = evaluateEval focus $ snd $ cmpRHS comp+ results = [[applyOp op f1 f2 | f2 <- f2s] | f1 <- f1s]+ in case (q1, q2) of+ (QAll, QAll) -> all and results+ (QAll, QAny) -> all or results+ (QAny, QAll) -> any and results+ (QAny, QAny) -> any or results++ evaluateEval :: Focus -> Evaluatable -> [Either Scientific Focus]+ evaluateEval focus eval = case eval of+ EText s -> [Right $ FText s]+ ENumber n -> [Left n]+ EFocuser (FTrav trav) -> Right <$> focus ^.. trav++ applyOp :: Oper -> Either Scientific Focus -> Either Scientific Focus -> Bool+ applyOp OpEq (Left n1) (Left n2) = n1 == n2+ applyOp OpEq (Right f1) (Right f2) = f1 == f2+ applyOp OpEq (Left n1) (Right (FText s2)) = Just n1 == readMaybeScientific s2+ applyOp OpEq (Right (FText s1)) (Left n2) = readMaybeScientific s1 == Just n2+ applyOp OpNe (Left n1) (Left n2) = n1 /= n2+ applyOp OpNe (Left n1) (Right (FText s2)) = case readMaybeScientific s2 of+ Just n2 -> n1 /= n2+ Nothing -> False+ applyOp OpNe (Right (FText s1)) (Left n2) = case readMaybeScientific s1 of+ Just n1 -> n1 /= n2+ Nothing -> False+ applyOp OpNe (Right f1) (Right f2) = f1 /= f2+ applyOp op e1 e2 = case op of+ OpLt -> applyOpOrd (<) e1 e2+ OpGt -> applyOpOrd (>) e1 e2+ OpLe -> applyOpOrd (<=) e1 e2+ OpGe -> applyOpOrd (>=) e1 e2+ _ -> False+ where+ applyOpOrd+ :: (forall a. Ord a => a -> a -> Bool)+ -> Either Scientific Focus+ -> Either Scientific Focus+ -> Bool+ applyOpOrd f (Left n1) (Left n2) = f n1 n2+ applyOpOrd f (Left n1) (Right (FText s2)) = case readMaybeScientific s2 of+ Just n2 -> f n1 n2+ Nothing -> False+ applyOpOrd f (Right (FText s1)) (Left n2) = case readMaybeScientific s1 of+ Just n1 -> f n1 n2+ Nothing -> False+ applyOpOrd f (Right (FText s1)) (Right (FText s2)) =+ case (readMaybeScientific s1, readMaybeScientific s2) of+ (Just n1, Just n2) -> f n1 n2+ _ -> f s1 s2+ applyOpOrd _ _ _ = False++logicFocuser :: (Focus -> Bool) -> Focuser+logicFocuser pred = FTrav $ lens+ (\focus -> if pred focus+ then FText "1"+ else FText "0")+ const++focusIsUpper :: Focuser+focusIsUpper = logicFocuser (\case+ FText s -> T.all isUpper s+ _ -> False)++focusIsLower :: Focuser+focusIsLower = logicFocuser (\case+ FText s -> T.all isLower s+ _ -> False)++focusIsAlpha :: Focuser+focusIsAlpha = logicFocuser (\case+ FText s -> T.all isAlpha s+ _ -> False)++focusIsAlphaNum :: Focuser+focusIsAlphaNum = logicFocuser (\case+ FText s -> T.all isAlphaNum s+ _ -> False)++focusIsDigit :: Focuser+focusIsDigit = logicFocuser (\case+ FText s -> T.all isDigit s+ _ -> False)++focusIsSpace :: Focuser+focusIsSpace = logicFocuser (\case+ FText s -> T.all isSpace s+ _ -> False)++focusRegex :: Text -> Focuser+focusRegex regex = FTrav $ \f focus -> case focus of+ FText s ->+ let matchIdxs = getAllMatches (s =~ regex)+ (nonMatches, matches) = fromIndexes 0 s matchIdxs+ newMatches = map toTextUnsafe <$> traverse (f . FText) matches+ in FText . T.concat . interleave nonMatches <$> newMatches+ _ -> pure focus+ where+ fromIndexes :: Int -> Text -> [(Int, Int)] -> ([Text], [Text])+ fromIndexes _ str [] = ([str], [])+ fromIndexes offset str ((i, j) : is) =+ let (nonMatch, T.splitAt j -> (match, str')) = T.splitAt (i - offset) str+ (nonMatches, matches) = fromIndexes (offset + i + j) str' is+ in (nonMatch : nonMatches, match : matches)+++focusFilter :: IfExpr -> Focuser+focusFilter pred = focusCollect $ focusEach `composeFocusers` focusIf pred++focusContains :: Text -> Focuser+focusContains text = FTrav $ lens contains const+ where+ contains focus = case focus of+ FText s -> FText $ if T.isInfixOf text s then "1" else "0"+ FList lst -> FText $ if any check lst then "1" else "0"+ check focus = case focus of+ FText s -> text == s+ _ -> False++focusStartsWith :: Text -> Focuser+focusStartsWith text = FTrav $ lens starts const+ where+ starts focus = case focus of+ FText s -> FText $ if T.isPrefixOf text s then "1" else "0"+ _ -> FText "0"++focusEndsWith :: Text -> Focuser+focusEndsWith text = FTrav $ lens ends const+ where+ ends focus = case focus of+ FText s -> FText $ if T.isSuffixOf text s then "1" else "0"+ _ -> FText "0"++focusLength :: Focuser+focusLength = FTrav $ \f focus -> case focus of+ FText s -> f . FText . T.pack . show . T.length $ s+ flst@(FList lst) -> flst <$ f (FText . T.pack . show . length $ lst)
+ src/Mappings.hs view
@@ -0,0 +1,122 @@+{-# OPTIONS_GHC -Wno-unused-do-bind #-}+{-# LANGUAGE ImpredicativeTypes #-}++module Mappings where++import Common (Evaluatable (..), Focus (FList, FText),+ Focuser (..), Mapping, Range, getIndexes,+ makeFilteredText, mapText, safeDiv,+ showScientific, toTextUnsafe)+import Control.Lens ((^..))+import Data.Char (toLower, toUpper)+import Data.Function (on)+import Data.List (sortBy)+import Data.Scientific (Scientific)+import Data.Text (Text)+import qualified Data.Text as T+import Text.Read (readMaybe)++mappingReverse :: Mapping+mappingReverse (FList lst) = FList (reverse lst)+mappingReverse (FText str) = FText (T.reverse str)++mappingLength :: Mapping+mappingLength (FText str) = FText $ T.pack $ show $ T.length str+mappingLength flist = flist++mappingMap :: Mapping -> Mapping+mappingMap mapping (FList lst) = FList $ map mapping lst+mappingMap mapping (FText str) = FText $ T.concat $ mapText+ (toTextUnsafe . mapping . FText . T.singleton) str++mappingAppend :: Evaluatable -> Mapping+mappingAppend (EText str') (FText str) = FText $ T.append str str'+mappingAppend (ENumber n) (FText str) = FText $ T.append str (showScientific n)+mappingAppend (EFocuser (FTrav trav)) fstr@(FText str) = case fstr ^.. trav of+ [FText s] -> FText $ T.append str s+ _ -> fstr+mappingAppend _ flist = flist++mappingPrepend :: Evaluatable -> Mapping+mappingPrepend (EText str') (FText str) = FText $ T.append str' str+mappingPrepend (ENumber n) (FText str) = FText $ T.append (showScientific n) str+mappingPrepend (EFocuser (FTrav trav)) fstr@(FText str) = case fstr ^.. trav of+ [FText s] -> FText $ T.append s str+ _ -> fstr+mappingPrepend _ flist = flist++mappingUpper :: Mapping+mappingUpper (FText str) = FText $ T.toUpper str+mappingUpper flist = flist++mappingLower :: Mapping+mappingLower (FText str) = FText $ T.toLower str+mappingLower flist = flist++mappingMath :: (Scientific -> Scientific) -> Mapping+mappingMath f (FText str) = case readMaybe $ T.unpack str of+ Nothing -> FText str+ Just n -> FText $ showScientific $ f n+mappingMath _ flist = flist++mappingAdd :: Scientific -> Mapping+mappingAdd = mappingMath . (+)++mappingSub :: Scientific -> Mapping+mappingSub = mappingMath . flip (-)++mappingMult :: Scientific -> Mapping+mappingMult = mappingMath . (*)++mappingDiv :: Scientific -> Mapping+mappingDiv = mappingMath . flip safeDiv++mappingPow :: Int -> Mapping+mappingPow = mappingMath . flip (^^)++mappingAbs :: Mapping+mappingAbs = mappingMath abs++mappingSign :: Mapping+mappingSign = mappingMath signum++mappingSlice :: [Range] -> Mapping+mappingSlice ranges (FText str) = FText filtered_str+ where+ str_length = T.length str+ is = getIndexes ranges str_length+ filtered_str = makeFilteredText str_length is str++mappingSlice _ flist = flist++mappingSortBy :: Focuser -> Mapping+mappingSortBy (FTrav trav) focus = case focus of+ FText str -> FText $ T.pack $ sortBy (cmp `on` (FText . T.singleton)) $ T.unpack str+ FList lst -> FList $ sortBy cmp lst+ where+ cmp f1 f2 =+ let f1' = f1 ^.. trav+ f2' = f2 ^.. trav+ in case (f1', f2') of+ ([FText s1], [FText s2]) -> case (readMDouble s1, readMDouble s2) of+ (Just n1, Just n2) -> compare n1 n2+ _ -> EQ+ _ -> EQ++ readMDouble :: Text -> Maybe Double+ readMDouble = readMaybe . T.unpack++mappingSortLexBy :: Focuser -> Mapping+mappingSortLexBy (FTrav trav) focus = case focus of+ FText str -> FText $ T.pack $ sortBy (cmp `on` (FText . T.singleton)) $ T.unpack str+ FList lst -> FList $ sortBy cmp lst+ where+ cmp f1 f2 =+ let f1' = f1 ^.. trav+ f2' = f2 ^.. trav+ in case (f1', f2') of+ ([FText s1], [FText s2]) -> compare s1 s2+ _ -> EQ++mappingId :: Mapping+mappingId = id
+ src/Parsers.hs view
@@ -0,0 +1,388 @@+{-# OPTIONS_GHC -Wno-unused-do-bind #-}+{-# LANGUAGE OverloadedStrings #-}++module Parsers where+import Common (Comparison (..), Evaluatable (..),+ Focuser (..), IfExpr (..), Mapping,+ Oper (..), Parser, Quantor (..),+ Range (..), composeFocusers, focusTo,+ foldFocusers, foldMappings, integer,+ lexeme, scient, symbol, mappingTo)+import Data.Char (isAlphaNum)+import Data.Functor (($>))+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Focusers (focusAverage, focusCollect, focusCols,+ focusContains, focusEach, focusEndsWith,+ focusFilter, focusId, focusIf,+ focusIndex, focusIsAlpha,+ focusIsAlphaNum, focusIsDigit,+ focusIsLower, focusIsSpace, focusIsUpper,+ focusLength, focusLines, focusMaxBy,+ focusMaxLexBy, focusMinBy, focusMinLexBy,+ focusProduct, focusRegex, focusSlice,+ focusSortedBy, focusSortedLexBy,+ focusSpace, focusStartsWith, focusSum,+ focusWords)+import Mappings (mappingAbs, mappingAdd, mappingAppend,+ mappingDiv, mappingId, mappingLength,+ mappingLower, mappingMap, mappingMult,+ mappingPow, mappingPrepend,+ mappingReverse, mappingSign,+ mappingSlice, mappingSortBy,+ mappingSortLexBy, mappingSub,+ mappingUpper)+import Text.Megaparsec (MonadParsec (try), anySingle, between,+ choice, empty, label, many, noneOf,+ notFollowedBy, optional, satisfy, sepBy,+ sepBy1, takeWhile1P, (<|>))+import Text.Megaparsec.Char (char, string)++-- Focuser parsers++parseFocuser :: Parser Focuser+parseFocuser = label "valid focuser" $ choice+ [ symbol "id" $> focusId+ , symbol "each" $> focusEach+ , parseFocusCollect+ , symbol "words" $> focusWords+ , symbol "lines" $> focusLines+ , symbol "ws" $> focusSpace+ , symbol "cols" $> focusCols+ , parseFocusSlice+ , parseFocusSortedLexBy+ , symbol "sortedLex" $> focusSortedLexBy focusId+ , parseFocusMinLexBy+ , parseFocusMaxLexBy+ , symbol "minLex" $> focusMinLexBy focusId+ , symbol "maxLex" $> focusMaxLexBy focusId+ , parseFocusSortedBy+ , parseFocusIndex+ , symbol "sorted" $> focusSortedBy focusId+ , parseFocusTo+ , symbol "len" $> focusLength+ , parseFocusMinBy+ , parseFocusMaxBy+ , symbol "min" $> focusMinBy focusId+ , symbol "max" $> focusMaxBy focusId+ , between (symbol "(") (symbol ")") $ foldFocusers <$> parseFocusers+ , symbol "sum" $> focusSum+ , symbol "product" $> focusProduct+ , parseFocusAverage+ , parseFocusAdd+ , parseFocusSub+ , parseFocusMult+ , parseFocusDiv+ , parseFocusPow+ , symbol "abs" $> focusTo mappingAbs+ , symbol "sign" $> focusTo mappingSign+ , parseFocusIf+ , symbol "isUpper" $> focusIsUpper+ , symbol "isLower" $> focusIsLower+ , symbol "isDigit" $> focusIsDigit+ , symbol "isAlphaNum" $> focusIsAlphaNum+ , symbol "isAlpha" $> focusIsAlpha+ , symbol "isSpace" $> focusIsSpace+ , parseFocusRegex+ , parseFocusFilter+ , parseFocusContains+ , parseFocusStartsWith+ , parseFocusEndsWith+ ]++parseFocusers :: Parser [Focuser]+parseFocusers = label "valid focuser stack" $ parseFocuser `sepBy1` symbol "."++parseFocusCollect :: Parser Focuser+parseFocusCollect = do+ symbol "<"+ focusers <- parseFocusers+ symbol ">"+ let focuser = foldFocusers focusers+ return $ focusCollect focuser++parseFocusSlice :: Parser Focuser+parseFocusSlice = do+ ranges <- between (symbol "{") (symbol "}") (range `sepBy` symbol ",")+ return $ focusSlice ranges++range :: Parser Range+range = try rangeRange <|> rangeSingle++rangeSingle :: Parser Range+rangeSingle = RangeSingle <$> integer++rangeRange :: Parser Range+rangeRange = label "range" $ do+ mstart <- lexeme $ optional integer+ symbol ":"+ mend <- lexeme $ optional integer+ return $ RangeRange mstart mend++parseFocusSortedBy :: Parser Focuser+parseFocusSortedBy = do+ lexeme $ string "sortedBy" >> notFollowedBy (satisfy isAlphaNum)+ focusSortedBy <$> parseFocuser++parseFocusIndex :: Parser Focuser+parseFocusIndex = do+ symbol "["+ n <- integer+ symbol "]"+ return $ focusIndex n++parseFocusTo :: Parser Focuser+parseFocusTo = do+ lexeme $ string "to" >> notFollowedBy (satisfy isAlphaNum)+ mapping <- foldMappings <$> parseMappings+ return $ focusTo mapping++parseFocusMinBy :: Parser Focuser+parseFocusMinBy = do+ lexeme $ string "minBy" >> notFollowedBy (satisfy isAlphaNum)+ focusMinBy <$> parseFocuser++parseFocusMaxBy :: Parser Focuser+parseFocusMaxBy = do+ lexeme $ string "maxBy" >> notFollowedBy (satisfy isAlphaNum)+ focusMaxBy <$> parseFocuser++parseFocusSortedLexBy :: Parser Focuser+parseFocusSortedLexBy = do+ lexeme $ string "sortedLexBy" >> notFollowedBy (satisfy isAlphaNum)+ focusSortedLexBy <$> parseFocuser++parseFocusMinLexBy :: Parser Focuser+parseFocusMinLexBy = do+ lexeme $ string "minLexBy" >> notFollowedBy (satisfy isAlphaNum)+ focusMinLexBy <$> parseFocuser++parseFocusMaxLexBy :: Parser Focuser+parseFocusMaxLexBy = do+ lexeme $ string "maxLexBy" >> notFollowedBy (satisfy isAlphaNum)+ focusMaxLexBy <$> parseFocuser++parseFocusAdd :: Parser Focuser+parseFocusAdd = do+ symbol "add "+ focusTo . mappingAdd <$> scient++parseFocusSub :: Parser Focuser+parseFocusSub = do+ symbol "sub "+ focusTo . mappingSub <$> scient++parseFocusMult :: Parser Focuser+parseFocusMult = do+ symbol "mult "+ focusTo . mappingMult <$> scient++parseFocusDiv :: Parser Focuser+parseFocusDiv = do+ symbol "div "+ focusTo . mappingDiv <$> scient++parseFocusPow :: Parser Focuser+parseFocusPow = do+ symbol "pow "+ focusTo . mappingPow <$> integer++parseFocusIf :: Parser Focuser+parseFocusIf = do+ lexeme $ string "if" >> notFollowedBy (satisfy isAlphaNum)+ ifExpr <- parseIfExpr+ return $ focusIf ifExpr++parseIfExpr :: Parser IfExpr+parseIfExpr = label "one or more blocks separated by '||'" $ do+ andBlocks <- parseAndBlock `sepBy1` symbol "||"+ case andBlocks of+ [] -> empty+ [block] -> return block+ _ -> return $ IfOr andBlocks++parseAndBlock :: Parser IfExpr+parseAndBlock = label "one or more blocks separated by '&&'" $ do+ atoms <- parseAtom `sepBy1` symbol "&&"+ case atoms of+ [] -> empty+ [atom] -> return atom+ _ -> return $ IfAnd atoms++parseAtom :: Parser IfExpr+parseAtom = between (symbol "(") (symbol ")") parseIfExpr <|> try parseComp <|> parseIfExprShort++parseComp :: Parser IfExpr+parseComp = do+ q1 <- fromMaybe QAll <$> optional parseQuantor+ lhs <- fromMaybe (EFocuser focusId) <$> optional parseEvaluatableLong+ comp <- parseCompOp+ q2 <- fromMaybe QAll <$> optional parseQuantor+ rhs <- parseEvaluatableLong+ return $ IfSingle $ Comparison (q1, lhs) comp (q2, rhs)++parseQuantor :: Parser Quantor+parseQuantor = symbol "all " $> QAll <|> symbol "any " $> QAny++parseCompOp :: Parser Oper+parseCompOp = choice+ [ symbol "=" $> OpEq+ , symbol "!=" $> OpNe+ , symbol "<=" $> OpLe+ , symbol "<" $> OpLt+ , symbol ">=" $> OpGe+ , symbol ">" $> OpGt+ ]++parseIfExprShort :: Parser IfExpr+parseIfExprShort = do+ q <- fromMaybe QAll <$> optional parseQuantor+ e <- EFocuser <$> parseFocuser+ return $ IfSingle $ Comparison (q, e) OpEq (QAny, EText "1")++parseFocusRegex :: Parser Focuser+parseFocusRegex = do+ symbol "regex"+ focusRegex <$> stringLiteral++parseFocusFilter :: Parser Focuser+parseFocusFilter = do+ lexeme $ string "filter" >> notFollowedBy (satisfy isAlphaNum)+ focusFilter <$> parseIfExpr++parseFocusContains :: Parser Focuser+parseFocusContains = do+ symbol "contains"+ focusContains <$> stringLiteral++parseFocusStartsWith :: Parser Focuser+parseFocusStartsWith = do+ symbol "startsWith"+ focusStartsWith <$> stringLiteral++parseFocusEndsWith :: Parser Focuser+parseFocusEndsWith = do+ symbol "endsWith"+ focusEndsWith <$> stringLiteral++parseFocusAverage :: Parser Focuser+parseFocusAverage = do+ symbol "average"+ def <- fromMaybe 0 <$> optional scient+ return $ focusAverage def++-- mapping parsers++parseMapping :: Parser Mapping+parseMapping = label "valid mapping" $ choice+ [ symbol "reverse" $> mappingReverse+ , symbol "len" $> mappingLength+ , parseMappingMap+ , parseMappingAppend+ , parseMappingPrepend+ , symbol "upper" $> mappingUpper+ , symbol "lower" $> mappingLower+ , between (symbol "(") (symbol ")") $ foldMappings <$> parseMappings+ , parseMappingAdd+ , parseMappingSub+ , parseMappingMult+ , parseMappingDiv+ , parseMappingPow+ , symbol "abs" $> mappingAbs+ , symbol "sign" $> mappingSign+ , parseMappingSlice+ , parseMappingSortLexBy+ , symbol "sortLex" $> mappingSortLexBy focusId+ , parseMappingSortBy+ , symbol "sort" $> mappingSortBy focusId+ , symbol "id" $> mappingId+ , parseMappingTo+ ]++parseMappings :: Parser [Mapping]+parseMappings = label "valid mapping stack" $ parseMapping `sepBy1` symbol ":"++parseMappingMap :: Parser Mapping+parseMappingMap = do+ lexeme $ string "map" >> notFollowedBy (satisfy isAlphaNum)+ mappingMap <$> parseMapping++parseEvaluatable :: Parser Evaluatable+parseEvaluatable =+ EText <$> stringLiteral <|>+ ENumber <$> scient <|>+ EFocuser <$> parseFocuser++parseEvaluatableLong :: Parser Evaluatable+parseEvaluatableLong =+ EText <$> stringLiteral <|>+ ENumber <$> scient <|>+ EFocuser . foldFocusers <$> parseFocusers++stringLiteral :: Parser Text+stringLiteral = label "string literal" $ lexeme $ do+ char '"'+ inner <- T.concat <$> many (choice+ [ takeWhile1P Nothing (\c -> c /= '/' && c /= '"')+ , try (string "\\\"" $> "\"")+ , string "\\"+ ])+ char '"'+ return inner++parseMappingAppend :: Parser Mapping+parseMappingAppend = do+ lexeme $ string "append" >> notFollowedBy (satisfy isAlphaNum)+ mappingAppend <$> parseEvaluatableLong++parseMappingPrepend :: Parser Mapping+parseMappingPrepend = do+ lexeme $ string "prepend" >> notFollowedBy (satisfy isAlphaNum)+ mappingPrepend <$> parseEvaluatableLong++parseMappingAdd :: Parser Mapping+parseMappingAdd = do+ symbol "add "+ mappingAdd <$> scient++parseMappingSub :: Parser Mapping+parseMappingSub = do+ symbol "sub "+ mappingSub <$> scient++parseMappingMult :: Parser Mapping+parseMappingMult = do+ symbol "mult "+ mappingMult <$> scient++parseMappingDiv :: Parser Mapping+parseMappingDiv = do+ symbol "div "+ mappingDiv <$> scient++parseMappingPow :: Parser Mapping+parseMappingPow = do+ symbol "pow "+ mappingPow <$> integer++parseMappingSlice :: Parser Mapping+parseMappingSlice = do+ ranges <- between (symbol "{") (symbol "}") (range `sepBy` symbol ",")+ return $ mappingSlice ranges++parseMappingSortBy :: Parser Mapping+parseMappingSortBy = do+ lexeme $ string "sortBy" >> notFollowedBy (satisfy isAlphaNum)+ mappingSortBy <$> parseFocuser++parseMappingSortLexBy :: Parser Mapping+parseMappingSortLexBy = do+ lexeme $ string "sortLexBy" >> notFollowedBy (satisfy isAlphaNum)+ mappingSortLexBy <$> parseFocuser++parseMappingTo :: Parser Mapping+parseMappingTo = do+ lexeme $ string "to" >> notFollowedBy (satisfy isAlphaNum)+ focuser <- foldFocusers <$> parseFocusers+ return $ mappingTo focuser
+ test/Main.hs view
@@ -0,0 +1,327 @@+{-# LANGUAGE GADTs #-}+module Main where++import Common (safeDiv, showScientific)+import Data.Char (isAlpha, isAlphaNum, isDigit, isLower,+ isSpace, isUpper, toLower, toUpper)+import Data.Function (on)+import Data.List (groupBy, transpose)+import Data.List.Extra (dropEnd, groupBy, sort, takeEnd, transpose)+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Scientific (Scientific)+import qualified Data.Text as T+import Focusers (interleave, myWords)+import System.IO.Unsafe (unsafePerformIO)+import System.Process (readProcess)+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))+import Text.Read (readMaybe)+import Focusers (readMaybeScientific)++main :: IO ()+main = defaultMain $ testGroup "All" [focuserTests, mappingTests]++focuserTests :: TestTree+focuserTests = testGroup "Focuser Tests"+ [ testGroup "id"+ [ "id|get-tree" $= show [input]+ ]+ , testGroup "each"+ [ "each|get" $= concatMap (: "\n") input+ , "<words>.each|get" $=$ "words|get"+ ]+ , testGroup "words"+ [ "words|get-tree" $= show (words input)+ , "words|over id" $= input+ ]+ , testGroup "lines"+ [ "lines|get-tree" $= show (lines input)+ , "lines|over id" $= input+ ]+ , testGroup "ws"+ [ "ws|get-tree" $= show (getWS input)+ , "ws|over id" $= input+ ]+ , testGroup "cols"+ [ "cols|get-tree" $= show (getCols input)+ , "cols|over id" $= input+ ]+ , testGroup "slice"+ [ "{0}|get-tree" $= show [take 1 input]+ , "{2}|get-tree" $= show [take 1 $ drop 2 input]+ , "{1:3}|get-tree" $= show [take 2 $ drop 1 input]+ , "{:5}|get-tree" $= show [take 5 input]+ , "{7:}|get-tree" $= show [drop 7 input]+ , "{-2}|get-tree" $= show [take 1 $ takeEnd 2 input]+ , "{-3:}|get-tree" $= show [takeEnd 3 input]+ , "{:-5}|get-tree" $= show [dropEnd 5 input]+ , "{-10:-4}|get-tree" $= show [take 6 $ takeEnd 10 input]+ , "{-1000:5}|get-tree" $=$ "{:5}|get-tree"+ , "{10:1000}|get-tree" $=$ "{10:}|get-tree"+ , "{1:5,7:10}|get-tree" $= show [take 4 (drop 1 input) ++ take 3 (drop 7 input)]+ , "{}|get-tree" $= "[\"\"]"+ , "{:}|get-tree" $= show [input]+ ]+ , testGroup "sortLexBy"+ [ "<words>.sortedLexBy id.each|get-tree" $= show (sort $ words input)+ , "<words>.sortedLexBy id.each|over id" $= input+ ]+ , testGroup "minLexBy/maxLexBy/minLex/maxLex"+ [ "<words>.minLexBy id|get-tree" $=$ "<words>.sortedLexBy id.[0]|get-tree"+ , "<words>.maxLexBy id|get-tree" $=$ "<words>.sortedLexBy id.[-1]|get-tree"+ , "<words>.minLex|get-tree" $=$ "<words>.minLexBy id|get-tree"+ , "<words>.maxLex|get-tree" $=$ "<words>.maxLexBy id|get-tree"+ ]+ , testGroup "sortedBy"+ [ "<words.if isDigit>.sortedBy id.each|get-tree" $=+ show (map showScientific $ sort $ map (read :: String -> Scientific) $ filter (all isDigit) $ words input)+ , "<words.if isAlpha>.sortedBy id.each|over id" $=$ "id|over id"+ ]+ , testGroup "sorted"+ [ "<words>.sorted|get-tree" $=$ "<words>.sortedBy id|get-tree"+ ]+ , testGroup "minBy/maxBy/min/max"+ [ "<words>.minBy id|get-tree" $=$ "<words>.sortedBy id.[0]|get-tree"+ , "<words>.maxBy id|get-tree" $=$ "<words>.sortedBy id.[-1]|get-tree"+ , "<words>.min|get-tree" $=$ "<words>.minBy id|get-tree"+ , "<words>.max|get-tree" $=$ "<words>.maxBy id|get-tree"+ ]+ , testGroup "index"+ [ "[3]|get-tree" $= show [take 1 $ drop 3 input]+ , "[-3]|get-tree" $= show [take 1 $ takeEnd 3 input]+ , "[-1000]|get-tree" $= "[]"+ , "[1000]|get-tree" $= "[]"+ ]+ , testGroup "to"+ [ "to upper|get-tree" $= show [map toUpper input]+ , "to lower|get-tree" $= show [map toLower input]+ , "to reverse|get-tree" $= show [reverse input]+ ]+ , testGroup "len"+ [ "len|get-tree" $=$ "to len|get-tree"+ , "len|get-tree" $= show [show $ length input]+ ]+ , testGroup "()"+ [ "(words).len|get-tree" $=$ "words.len|get-tree"+ , "words.(len)|get-tree" $=$ "words.len|get-tree"+ , "(words.len)|get-tree" $=$ "words.len|get-tree"+ ]+ , testGroup "sum"+ [ "<words>.sum|get-tree" $= show [showScientific (sum $ inputNums input)]+ , "words.sum|get-tree" $=+ show (map (showScientific . sum . mapMaybe (readMaybeScientific . T.pack . (:[]))) $ words input)+ ]+ , testGroup "product"+ [ "<words>.product|get-tree" $= show [showScientific (product $ inputNums input)]+ , "words.product|get-tree" $=+ show (map (showScientific . product . mapMaybe (readMaybeScientific . T.pack . (:[]))) $ words input)+ ]+ , testGroup "average"+ [ "<words>.average|get-tree" $= show [showScientific (average $ inputNums input)]+ , "words.average|get-tree" $=+ show (map (showScientific . average . mapMaybe (readMaybeScientific . T.pack . (:[]))) $ words input)+ ]+ , testGroup "add"+ [ "<words.add 1>.sum|get-tree" $= show [showScientific (sum $ map (+1) $ inputNums input)]+ ]+ , testGroup "sub"+ [ "<words.sub 1>.sum|get-tree" $= show [showScientific (sum $ map (subtract 1) $ inputNums input)]+ ]+ , testGroup "mult"+ [ "<words.mult 2>.sum|get-tree" $= show [showScientific (sum $ map (*2) $ inputNums input)]+ ]+ , testGroup "div"+ [ "<words.div 2>.sum|get-tree" $= show [showScientific (sum $ map (`safeDiv` 2) $ inputNums input)]+ ]+ , testGroup "pow"+ [ "<words.pow 2>.sum|get-tree" $= show [showScientific (sum $ map (^^ 2) $ inputNums input)]+ ]+ , testGroup "abs"+ [ "<words.abs>.sum|get-tree" $= show [showScientific (sum $ map abs $ inputNums input)]+ ]+ , testGroup "sign"+ [ "<words.sign>.sum|get-tree" $= show [showScientific (sum $ map signum $ inputNums input)]+ ]+ , testGroup "if"+ [ "words.if 1=1|get-tree" $= show (words input)+ , "words.if 1=2|get-tree" $= "[]"+ , "words.if \"1\"=\"1\"|get-tree" $= show (words input)+ , "words.if \"1\"=\"2\"|get-tree" $= "[]"+ , "words.if 1=\"1\"|get-tree" $= show (words input)+ , "words.if 1=\"2\"|get-tree" $= "[]"+ , "words.if \"1\"=1|get-tree" $= show (words input)+ , "words.if \"1\"=2|get-tree" $= "[]"+ , "words.if id<=id|get-tree" $= show (words input)+ , "words.if id=len|get-tree" $= show (filter (\w -> w == show (length w)) $ words input)+ , "words.if len=2|get-tree" $= show (filter (\w -> length w == 2) $ words input)+ , "words.if len=\"3\"|get-tree" $= show (filter (\w -> length w == 3) $ words input)+ , "<words>.if id<=id|get-tree" $= "[]"+ , "<words>.if id<id|get-tree" $= "[]"+ , "<words>.if id>id|get-tree" $= "[]"+ , "<words>.if id>=id|get-tree" $= "[]"+ , "words.if len<3 && len>1|get-tree" $= show (filter (\w -> length w < 3 && length w > 1) $ words input)+ , "words.if len<2 || len>2|get-tree" $= show (filter (\w -> length w < 2 || length w > 2) $ words input)+ , "words.if len>1 && len<3 || [0].isUpper=1|get-tree" $=+ show (filter (\w -> length w > 1 && length w < 3 || isUpper (head w)) $ words input)+ , "words.if [0].isUpper=1 || len>1 && len<3|get-tree" $=+ show (filter (\w -> isUpper (head w) || length w > 1 && length w < 3) $ words input)+ , "words.if ([0].isUpper=1 || len>1) && len<3|get-tree" $=+ show (filter (\w -> (isUpper (head w) || length w > 1) && length w < 3) $ words input)+ , "words.if len|get-tree" $= show (filter (\w -> length w == 1) $ words input)+ , "words.if all (each.isUpper)|get-tree" $= show (filter (all isUpper) $ words input)+ , "words.if any (each.isUpper)|get-tree" $= show (filter (any isUpper) $ words input)+ , "words.if 1=all each.isUpper|get-tree" $= show (filter (all isUpper) $ words input)+ , "words.if 1=any each.isUpper|get-tree" $= show (filter (any isUpper) $ words input)+ , "words.if each=each|get-tree" $= show (filter allEqual $ words input)+ , "words.if =\"ee\"|get-tree" $=$ "words.if id=\"ee\"|get-tree"+ ]+ , testGroup "isUpper"+ [ "words.if isUpper|get-tree" $= show (filter (all isUpper) $ words input)+ ]+ , testGroup "isLower"+ [ "words.if isLower|get-tree" $= show (filter (all isLower) $ words input)+ ]+ , testGroup "isAlpha"+ [ "words.if isAlpha|get-tree" $= show (filter (all isAlpha) $ words input)+ ]+ , testGroup "isAlphaNum"+ [ "words.if isAlphaNum|get-tree" $= show (filter (all isAlphaNum) $ words input)+ ]+ , testGroup "isSpace"+ [ "words.if isSpace|get-tree" $= show (filter (all isSpace) $ words input)+ ]+ , testGroup "isDigit"+ [ "words.if isDigit|get-tree" $= show (filter (all isDigit) $ words input)+ ]+ , testGroup "collect"+ [ "<words>|get-tree" $= show [words input]+ ]+ , testGroup "filter"+ [ "<words>.filter len<3.each|get-tree" $=$ "words.if len<3|get-tree" ]+ ]++mappingTests :: TestTree+mappingTests = testGroup "Mapping Tests"+ [ testGroup "reverse"+ [ "id|over reverse" $= reverse input+ , "id|over reverse:reverse" $= input+ ]+ , testGroup "length"+ [ "id|over len" $= show (length input)+ ]+ , testGroup "map"+ [ "<words>|over map len" $= "1 2 3 3 1 1 1 1\n1 2 3 3 1 1 1 1 1\n1 2 3 3 1 1 1 1 1\n\n"+ , "words|over map upper" $=$ "words|over upper"+ , "id|over id" $= input+ ]+ , testGroup "append/prepend"+ [ "id|over append \"\"" $= input+ , "id|over prepend \"\"" $= input+ , "id|over append 1" $= (input ++ "1")+ , "id|over prepend 1" $= ("1" ++ input)+ , "id|over append \"hello\"" $= (input ++ "hello")+ , "id|over prepend \"hello\"" $= ("hello" ++ input)+ , "id|over append len" $= (input ++ show (length input))+ , "id|over prepend len" $= (show (length input) ++ input)+ , "id|over prepend <words>" $= input+ ]+ , testGroup "upper/lower"+ [ "id|over upper" $= map toUpper input+ , "id|over lower" $= map toLower input+ ]+ , testGroup "add/sub/div/pow/abs/sign"+ [ "id|over add 1" $= mapNums (+ 1) input+ , "id|over sub 1" $= mapNums (subtract 1) input+ , "id|over div 2" $= mapNums (`safeDiv` 2) input+ , "id|over pow 2" $= mapNums (^^ 2) input+ , "id|over abs" $= mapNums abs input+ , "id|over sign" $= mapNums signum input+ ]+ , testGroup "slice"+ [ "id|over {0}" $= take 1 input+ , "id|over {2}" $= take 1 (drop 2 input)+ , "id|over {1:3}" $= take 2 ( drop 1 input)+ , "id|over {:5}" $= take 5 input+ , "id|over {7:}" $= drop 7 input+ , "id|over {-2}" $= take 1 ( takeEnd 2 input)+ , "id|over {-3:}" $= takeEnd 3 input+ , "id|over {:-5}" $= dropEnd 5 input+ , "id|over {-10:-4}" $= take 6 ( takeEnd 10 input)+ , "id|over {-1000:5}" $=$ "id|over {:5}"+ , "id|over {10:1000}" $=$ "id|over {10:}"+ , "id|over {1:5,7:10}" $= take 4 (drop 1 input) ++ take 3 (drop 7 input)+ , "id|over {}" $= ""+ , "id|over {:}" $= input+ ]+ , testGroup "sortLexBy"+ [ "<words>|over sortLexBy id" $= "1 1 2 2 3 3 Ccc Hhh\nMmm _ _ _ _ _ a bb dd1\ne f gg ii2 j k ll nn3 o\n\n"+ , "<words.<each>>|over sortLexBy id" $= input+ ]+ , testGroup "sortLex"+ [ "<words>|over sortLexBy id" $=$ "<words>|over sortLex"+ ]+ , testGroup "sortBy"+ [ "<words>|over sortBy id" $= "a bb Ccc dd1 e 1 1 3\n_ f gg Hhh ii2 j 2 2 _\n_ k ll Mmm nn3 o 3 _ _\n\n"+ , "<words.<each>>|over sortBy id" $= input+ ]+ , testGroup "sort"+ [ "<words>|over sortBy id" $=$ "<words>|over sort"+ ]+ , testGroup "id"+ [ "<words>|over id" $= input+ ]+ , testGroup "to"+ [ "words|over to len" $=$ "words|over len" ]+ ]++allEqual :: (Eq a) => [a] -> Bool+allEqual [] = True+allEqual (x:xs) = all (== x) xs++anyEqual :: (Eq a) => [a] -> Bool+anyEqual [] = False+anyEqual (x:xs) = x `elem` xs || anyEqual xs++mapNums :: (Scientific -> Scientific) -> String -> String+mapNums f str =+ let (ws, words) = myWords $ T.pack str+ new_words = map (mapNum f . T.unpack) words+ in T.unpack $ T.concat $ interleave ws words+ where+ mapNum :: (Scientific -> Scientific) -> String -> String+ mapNum f str = case readMaybe str of+ Nothing -> str+ Just n -> T.unpack $ showScientific $ f n++getWS :: String -> [String]+getWS str =+ let groups = groupBy (\c1 c2 -> isSpace c1 == isSpace c2) str+ in filter (isSpace . head) groups++getCols :: String -> [[String]]+getCols = transpose . map words . lines++inputNums :: String -> [Scientific]+inputNums str = mapMaybe readMaybe $ words str++average :: [Scientific] -> Scientific+average [] = 0+average ns = sum ns `safeDiv` fromIntegral (length ns)++{-# NOINLINE input #-}+input :: String+input = unsafePerformIO $ readFile "test/input.txt"++infixl 1 $=+($=) :: String -> String -> TestTree+($=) command desiredOutput = testCase command $ do+ output <- readProcess "./smh" [command] input+ output @?= desiredOutput++infixl 1 $=$+($=$) :: String -> String -> TestTree+($=$) cmd1 cmd2 = testCase (cmd1 ++ " == " ++ cmd2) $ do+ out1 <- readProcess "./smh" [cmd1] input+ out2 <- readProcess "./smh" [cmd2] input+ out1 @?= out2+