{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- for Binary instance of Hashmap

-- |
-- Module      :  Yi.Utils
-- License     :  GPL-2
-- Maintainer  :  yi-devel@googlegroups.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Various utility functions and instances used throughout Yi. Some of
-- the functions from the now-removed Yi.Prelude found a new home
-- here.

module Yi.Utils where

import           Lens.Micro.Platform
import           Control.Monad.Base
import           Data.Binary
import           Data.Char (toLower)
import qualified Data.HashMap.Strict as HashMap
import           Data.Hashable(Hashable)
import qualified Data.List.PointedList as PL
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Language.Haskell.TH.Syntax as THS

io :: MonadBase IO m => IO a -> m a
io :: forall (m :: * -> *) a. MonadBase IO m => IO a -> m a
io = IO a -> m a
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase

fst3 :: (a,b,c) -> a
fst3 :: forall a b c. (a, b, c) -> a
fst3 (a
x,b
_,c
_) = a
x

snd3 :: (a,b,c) -> b
snd3 :: forall a b c. (a, b, c) -> b
snd3 (a
_,b
x,c
_) = b
x

trd3 :: (a,b,c) -> c
trd3 :: forall a b c. (a, b, c) -> c
trd3 (a
_,b
_,c
x) = c
x

class SemiNum absolute relative | absolute -> relative where
    (+~) :: absolute -> relative -> absolute
    (-~) :: absolute -> relative -> absolute
    (~-) :: absolute -> absolute -> relative

{-# ANN nubSet "HLint: ignore Eta reduce" #-}
-- TODO: move somewhere else.
-- | As 'Prelude.nub', but with O(n*log(n)) behaviour.
nubSet :: (Ord a) => [a] -> [a]
nubSet :: forall a. Ord a => [a] -> [a]
nubSet [a]
xss = Set a -> [a] -> [a]
forall {a}. Ord a => Set a -> [a] -> [a]
f Set a
forall a. Set a
Set.empty [a]
xss
  where
      f :: Set a -> [a] -> [a]
f Set a
_ [] = []
      f Set a
s (a
x:[a]
xs) = if a
x a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
s then Set a -> [a] -> [a]
f Set a
s [a]
xs else a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Set a -> [a] -> [a]
f (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
s) [a]
xs

-- | As Map.adjust, but the combining function is applied strictly.
mapAdjust' :: (Ord k) => (a -> a) -> k -> Map.Map k a -> Map.Map k a
mapAdjust' :: forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
mapAdjust' a -> a
f = (Maybe a -> Maybe a) -> k -> Map k a -> Map k a
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe a -> Maybe a
f' where
    f' :: Maybe a -> Maybe a
f' Maybe a
Nothing = Maybe a
forall a. Maybe a
Nothing
    f' (Just a
x) = let x' :: a
x' = a -> a
f a
x in a
x' a -> Maybe a -> Maybe a
forall a b. a -> b -> b
`seq` a -> Maybe a
forall a. a -> Maybe a
Just a
x'
    -- This works because Map is structure-strict, and alter needs to force f' to compute
    -- the structure.

-- | Generalisation of 'Map.fromList' to arbitrary foldables.
mapFromFoldable :: (Foldable t, Ord k) => t (k, a) -> Map.Map k a
mapFromFoldable :: forall (t :: * -> *) k a.
(Foldable t, Ord k) =>
t (k, a) -> Map k a
mapFromFoldable = ((k, a) -> Map k a) -> t (k, a) -> Map k a
forall m a. Monoid m => (a -> m) -> t a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((k -> a -> Map k a) -> (k, a) -> Map k a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry k -> a -> Map k a
forall k a. k -> a -> Map k a
Map.singleton)

-- | Alternative to groupBy.
--
-- > groupBy' (\a b -> abs (a - b) <= 1) [1,2,3] = [[1,2,3]]
--
-- whereas
--
-- > groupBy (\a b -> abs (a - b) <= 1) [1,2,3] = [[1,2],[3]]
--
-- TODO: Check in ghc 6.12 release if groupBy == groupBy'.
groupBy' :: (a -> a -> Bool) -> [a] -> [[a]]
groupBy' :: forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy' a -> a -> Bool
_ [] = []
groupBy' a -> a -> Bool
p [a]
l = [a]
s1 [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: (a -> a -> Bool) -> [a] -> [[a]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy' a -> a -> Bool
p [a]
s2 where
    ([a]
s1, [a]
s2) = (a -> a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> a -> Bool) -> [a] -> ([a], [a])
chain a -> a -> Bool
p [a]
l

chain :: (a -> a -> Bool) -> [a] -> ([a],[a])
chain :: forall a. (a -> a -> Bool) -> [a] -> ([a], [a])
chain a -> a -> Bool
_ [] = ([], [])
chain a -> a -> Bool
_ [a
e] = ([a
e], [])
chain a -> a -> Bool
q (a
e1 : es :: [a]
es@(a
e2 : [a]
_))
    | a -> a -> Bool
q a
e1 a
e2 = let ([a]
s1, [a]
s2) = (a -> a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> a -> Bool) -> [a] -> ([a], [a])
chain a -> a -> Bool
q [a]
es in (a
e1 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
s1, [a]
s2)
    | Bool
otherwise = ([a
e1], [a]
es)

-- | Return the longest common prefix of a set of lists.
--
-- > P(xs) === all (isPrefixOf (commonPrefix xs)) xs
-- > length s > length (commonPrefix xs) --> not (all (isPrefixOf s) xs)
commonPrefix :: Eq a => [[a]] -> [a]
commonPrefix :: forall a. Eq a => [[a]] -> [a]
commonPrefix [] = []
commonPrefix [[a]]
strings
    | ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[a]]
strings = []
    | (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
prefix) [a]
heads = a
prefix a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [[a]] -> [a]
forall a. Eq a => [[a]] -> [a]
commonPrefix [[a]]
tailz
    | Bool
otherwise = []
    where
          ([a]
heads, [[a]]
tailz) = [(a, [a])] -> ([a], [[a]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(a
h,[a]
t) | (a
h:[a]
t) <- [[a]]
strings]
          prefix :: a
prefix = [a] -> a
forall a. HasCallStack => [a] -> a
head [a]
heads
-- for an alternative implementation see GHC's InteractiveUI module.

{-# ANN findPL "HLint: ignore Eta reduce" #-}
---------------------- PointedList stuff
-- | Finds the first element satisfying the predicate, and returns a zipper pointing at it.
findPL :: (a -> Bool) -> [a] -> Maybe (PL.PointedList a)
findPL :: forall a. (a -> Bool) -> [a] -> Maybe (PointedList a)
findPL a -> Bool
p [a]
xs = [a] -> [a] -> Maybe (PointedList a)
go [] [a]
xs where
  go :: [a] -> [a] -> Maybe (PointedList a)
go [a]
_  [] = Maybe (PointedList a)
forall a. Maybe a
Nothing
  go [a]
ls (a
f:[a]
rs) | a -> Bool
p a
f    = PointedList a -> Maybe (PointedList a)
forall a. a -> Maybe a
Just ([a] -> a -> [a] -> PointedList a
forall a. [a] -> a -> [a] -> PointedList a
PL.PointedList [a]
ls a
f [a]
rs)
               | Bool
otherwise = [a] -> [a] -> Maybe (PointedList a)
go (a
fa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ls) [a]
rs

{-# ANN swapFocus "HLint: ignore Redundant bracket" #-}
-- | Given a function which moves the focus from index A to index B, return a function which swaps the elements at indexes A and B and then moves the focus. See Yi.Editor.swapWinWithFirstE for an example.
swapFocus :: (PL.PointedList a -> PL.PointedList a) -> (PL.PointedList a -> PL.PointedList a)
swapFocus :: forall a.
(PointedList a -> PointedList a) -> PointedList a -> PointedList a
swapFocus PointedList a -> PointedList a
moveFocus PointedList a
xs =
    let xs' :: PointedList a
xs' = PointedList a -> PointedList a
moveFocus PointedList a
xs
        f1 :: a
f1  = Getting a (PointedList a) a -> PointedList a -> a
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting a (PointedList a) a
forall (f :: * -> *) a.
Functor f =>
(a -> f a) -> PointedList a -> f (PointedList a)
PL.focus PointedList a
xs
        f2 :: a
f2  = Getting a (PointedList a) a -> PointedList a -> a
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting a (PointedList a) a
forall (f :: * -> *) a.
Functor f =>
(a -> f a) -> PointedList a -> f (PointedList a)
PL.focus PointedList a
xs'
    in ASetter (PointedList a) (PointedList a) a a
-> a -> PointedList a -> PointedList a
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter (PointedList a) (PointedList a) a a
forall (f :: * -> *) a.
Functor f =>
(a -> f a) -> PointedList a -> f (PointedList a)
PL.focus a
f1 (PointedList a -> PointedList a)
-> (PointedList a -> PointedList a)
-> PointedList a
-> PointedList a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PointedList a -> PointedList a
moveFocus (PointedList a -> PointedList a)
-> (PointedList a -> PointedList a)
-> PointedList a
-> PointedList a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter (PointedList a) (PointedList a) a a
-> a -> PointedList a -> PointedList a
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter (PointedList a) (PointedList a) a a
forall (f :: * -> *) a.
Functor f =>
(a -> f a) -> PointedList a -> f (PointedList a)
PL.focus a
f2 (PointedList a -> PointedList a) -> PointedList a -> PointedList a
forall a b. (a -> b) -> a -> b
$ PointedList a
xs

----------------- Orphan 'Binary' instances
instance (Eq k, Hashable k, Binary k, Binary v) => Binary (HashMap.HashMap k v) where
    put :: HashMap k v -> Put
put HashMap k v
x = [(k, v)] -> Put
forall t. Binary t => t -> Put
put (HashMap k v -> [(k, v)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap k v
x)
    get :: Get (HashMap k v)
get = [(k, v)] -> HashMap k v
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(k, v)] -> HashMap k v) -> Get [(k, v)] -> Get (HashMap k v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get [(k, v)]
forall t. Binary t => Get t
get

makeClassyWithSuffix :: String -> THS.Name -> THS.Q [THS.Dec]
makeClassyWithSuffix :: String -> Name -> Q [Dec]
makeClassyWithSuffix String
s = LensRules -> Name -> Q [Dec]
makeLensesWith (LensRules
classyRules
  LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& ((Name -> [Name] -> Name -> [DefName])
 -> Identity (Name -> [Name] -> Name -> [DefName]))
-> LensRules -> Identity LensRules
Lens' LensRules (Name -> [Name] -> Name -> [DefName])
lensField (((Name -> [Name] -> Name -> [DefName])
  -> Identity (Name -> [Name] -> Name -> [DefName]))
 -> LensRules -> Identity LensRules)
-> (Name -> [Name] -> Name -> [DefName]) -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (\Name
_ [Name]
_ Name
n -> Name -> String -> [DefName]
addSuffix Name
n String
s)
  LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& ((Name -> Maybe (Name, Name))
 -> Identity (Name -> Maybe (Name, Name)))
-> LensRules -> Identity LensRules
Lens' LensRules (Name -> Maybe (Name, Name))
lensClass (((Name -> Maybe (Name, Name))
  -> Identity (Name -> Maybe (Name, Name)))
 -> LensRules -> Identity LensRules)
-> (Name -> Maybe (Name, Name)) -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Name -> Maybe (Name, Name)
classy)
  where
    classy :: THS.Name -> Maybe (THS.Name, THS.Name)
    classy :: Name -> Maybe (Name, Name)
classy Name
n = case Name -> String
THS.nameBase Name
n of
      Char
x:String
xs -> (Name, Name) -> Maybe (Name, Name)
forall a. a -> Maybe a
Just (String -> Name
THS.mkName (String
"Has" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs),
                    String -> Name
THS.mkName (Char -> Char
toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s))
      []   -> Maybe (Name, Name)
forall a. Maybe a
Nothing

addSuffix :: THS.Name -> String -> [DefName]
addSuffix :: Name -> String -> [DefName]
addSuffix Name
n String
s = [Name -> DefName
TopName (Name -> DefName) -> Name -> DefName
forall a b. (a -> b) -> a -> b
$ String -> Name
THS.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
THS.nameBase Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s]

makeLensesWithSuffix :: String -> THS.Name -> THS.Q [THS.Dec]
makeLensesWithSuffix :: String -> Name -> Q [Dec]
makeLensesWithSuffix String
s =
  LensRules -> Name -> Q [Dec]
makeLensesWith (LensRules
lensRules LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& ((Name -> [Name] -> Name -> [DefName])
 -> Identity (Name -> [Name] -> Name -> [DefName]))
-> LensRules -> Identity LensRules
Lens' LensRules (Name -> [Name] -> Name -> [DefName])
lensField (((Name -> [Name] -> Name -> [DefName])
  -> Identity (Name -> [Name] -> Name -> [DefName]))
 -> LensRules -> Identity LensRules)
-> (Name -> [Name] -> Name -> [DefName]) -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (\Name
_ [Name]
_ Name
n -> Name -> String -> [DefName]
addSuffix Name
n String
s))