{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
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 :: IO a -> m a
io = IO a -> m a
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase
fst3 :: (a,b,c) -> a
fst3 :: (a, b, c) -> a
fst3 (x :: a
x,_,_) = a
x
snd3 :: (a,b,c) -> b
snd3 :: (a, b, c) -> b
snd3 (_,x :: b
x,_) = b
x
trd3 :: (a,b,c) -> c
trd3 :: (a, b, c) -> c
trd3 (_,_,x :: 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" #-}
nubSet :: (Ord a) => [a] -> [a]
nubSet :: [a] -> [a]
nubSet xss :: [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 _ [] = []
f s :: Set a
s (x :: a
x:xs :: [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
mapAdjust' :: (Ord k) => (a -> a) -> k -> Map.Map k a -> Map.Map k a
mapAdjust' :: (a -> a) -> k -> Map k a -> Map k a
mapAdjust' f :: 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' Nothing = Maybe a
forall a. Maybe a
Nothing
f' (Just x :: 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'
mapFromFoldable :: (Foldable t, Ord k) => t (k, a) -> Map.Map k a
mapFromFoldable :: t (k, a) -> Map k a
mapFromFoldable = ((k, a) -> Map k a) -> t (k, a) -> Map k a
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)
groupBy' :: (a -> a -> Bool) -> [a] -> [[a]]
groupBy' :: (a -> a -> Bool) -> [a] -> [[a]]
groupBy' _ [] = []
groupBy' p :: a -> a -> Bool
p l :: [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
(s1 :: [a]
s1, s2 :: [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 :: (a -> a -> Bool) -> [a] -> ([a], [a])
chain _ [] = ([], [])
chain _ [e :: a
e] = ([a
e], [])
chain q :: a -> a -> Bool
q (e1 :: a
e1 : es :: [a]
es@(e2 :: a
e2 : _))
| a -> a -> Bool
q a
e1 a
e2 = let (s1 :: [a]
s1, s2 :: [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)
commonPrefix :: Eq a => [[a]] -> [a]
commonPrefix :: [[a]] -> [a]
commonPrefix [] = []
commonPrefix strings :: [[a]]
strings
| ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any [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
(heads :: [a]
heads, tailz :: [[a]]
tailz) = [(a, [a])] -> ([a], [[a]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(a
h,[a]
t) | (h :: a
h:t :: [a]
t) <- [[a]]
strings]
prefix :: a
prefix = [a] -> a
forall a. [a] -> a
head [a]
heads
{-# ANN findPL "HLint: ignore Eta reduce" #-}
findPL :: (a -> Bool) -> [a] -> Maybe (PL.PointedList a)
findPL :: (a -> Bool) -> [a] -> Maybe (PointedList a)
findPL p :: a -> Bool
p xs :: [a]
xs = [a] -> [a] -> Maybe (PointedList a)
go [] [a]
xs where
go :: [a] -> [a] -> Maybe (PointedList a)
go _ [] = Maybe (PointedList a)
forall a. Maybe a
Nothing
go ls :: [a]
ls (f :: a
f:rs :: [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" #-}
swapFocus :: (PL.PointedList a -> PL.PointedList a) -> (PL.PointedList a -> PL.PointedList a)
swapFocus :: (PointedList a -> PointedList a) -> PointedList a -> PointedList a
swapFocus moveFocus :: PointedList a -> PointedList a
moveFocus xs :: 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
instance (Eq k, Hashable k, Binary k, Binary v) => Binary (HashMap.HashMap k v) where
put :: HashMap k v -> Put
put x :: 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 s :: 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
.~ (\_ _ n :: 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 n :: Name
n = case Name -> String
THS.nameBase Name
n of
x :: Char
x:xs :: String
xs -> (Name, Name) -> Maybe (Name, Name)
forall a. a -> Maybe a
Just (String -> Name
THS.mkName ("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 n :: Name
n s :: 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 s :: 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
.~ (\_ _ n :: Name
n -> Name -> String -> [DefName]
addSuffix Name
n String
s))