smh-0.2.1: src/Mappings.hs

{-# OPTIONS_GHC -Wno-unused-do-bind #-}
{-# LANGUAGE ImpredicativeTypes #-}

module Mappings where

import           Common        (Focus (FList, FText), Focuser (..), Mapping,
                                Range, getIndexes, makeFilteredText, mapText,
                                readMaybeRational, showRational, toTextUnsafe)
import           Control.Lens  ((^..))
import           Data.Char     (toLower, toUpper)
import           Data.Function (on)
import           Data.List     (sortBy)
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 :: Focuser -> Mapping
mappingAppend (FTrav trav) fstr@(FText str) = case fstr ^.. trav of
    [FText s] -> FText $ T.append str s
    _         -> fstr
mappingAppend _ flist            = flist

mappingPrepend :: Focuser -> Mapping
mappingPrepend (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 :: (Rational -> Rational) -> Mapping
mappingMath f (FText str) = case readMaybeRational str of
    Nothing -> FText str
    Just n  -> FText $ showRational $ f n
mappingMath _ flist         = flist

mappingAdd :: Rational -> Mapping
mappingAdd = mappingMath . (+)

mappingSub :: Rational -> Mapping
mappingSub = mappingMath . flip (-)

mappingMult :: Rational -> Mapping
mappingMult = mappingMath . (*)

mappingDiv :: Rational -> Mapping
mappingDiv = mappingMath . flip (/)

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