{-# LANGUAGE CPP #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
module Nix.Utils (module Nix.Utils, module X) where
import Control.Monad.Fix ( MonadFix(..) )
import Control.Monad.Free ( Free(..) )
import Control.Monad.Trans.Control ( MonadTransControl(..) )
import qualified Data.Aeson as A
import qualified Data.Aeson.Encoding as A
import Data.Fix ( Fix(..) )
import qualified Data.HashMap.Lazy as M
import qualified Data.Text as Text
import qualified Data.Vector as V
import Lens.Family2 as X hiding ((&))
import Lens.Family2.Stock ( _1
, _2
)
import Lens.Family2.TH ( makeLensesBy )
#if ENABLE_TRACING
import Debug.Trace as X
#else
trace :: String -> a -> a
trace :: String -> a -> a
trace = (a -> a) -> String -> a -> a
forall a b. a -> b -> a
const a -> a
forall a. a -> a
id
{-# inline trace #-}
traceM :: Monad m => String -> m ()
traceM :: String -> m ()
traceM = m () -> String -> m ()
forall a b. a -> b -> a
const m ()
forall (f :: * -> *). Applicative f => f ()
pass
{-# inline traceM #-}
#endif
$(makeLensesBy (\n -> pure $ "_" <> n) ''Fix)
type AttrSet = HashMap Text
type Alg f a = f a -> a
type AlgM f m a = f a -> m a
type Transform f a = TransformF (Fix f) a
type TransformF f a = (f -> a) -> f -> a
loeb :: Functor f => f (f a -> a) -> f a
loeb :: f (f a -> a) -> f a
loeb f (f a -> a)
x = f a
go
where
go :: f a
go = ((f a -> a) -> f a -> a
forall a b. (a -> b) -> a -> b
$ f a
go) ((f a -> a) -> a) -> f (f a -> a) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (f a -> a)
x
loebM :: (MonadFix m, Traversable t) => t (t a -> m a) -> m (t a)
loebM :: t (t a -> m a) -> m (t a)
loebM t (t a -> m a)
f = (t a -> m (t a)) -> m (t a)
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((t a -> m (t a)) -> m (t a)) -> (t a -> m (t a)) -> m (t a)
forall a b. (a -> b) -> a -> b
$ \t a
a -> (((t a -> m a) -> m a) -> t (t a -> m a) -> m (t a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
`traverse` t (t a -> m a)
f) ((t a -> m a) -> t a -> m a
forall a b. (a -> b) -> a -> b
$ t a
a)
{-# inline loebM #-}
para :: Functor f => (f (Fix f, a) -> a) -> Fix f -> a
para :: (f (Fix f, a) -> a) -> Fix f -> a
para f (Fix f, a) -> a
f = f (Fix f, a) -> a
f (f (Fix f, a) -> a) -> (Fix f -> f (Fix f, a)) -> Fix f -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fix f -> (Fix f, a)) -> f (Fix f) -> f (Fix f, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Fix f -> Fix f
forall a. a -> a
id (Fix f -> Fix f) -> (Fix f -> a) -> Fix f -> (Fix f, a)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (f (Fix f, a) -> a) -> Fix f -> a
forall (f :: * -> *) a.
Functor f =>
(f (Fix f, a) -> a) -> Fix f -> a
para f (Fix f, a) -> a
f) (f (Fix f) -> f (Fix f, a))
-> (Fix f -> f (Fix f)) -> Fix f -> f (Fix f, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix
paraM :: (Traversable f, Monad m) => (f (Fix f, a) -> m a) -> Fix f -> m a
paraM :: (f (Fix f, a) -> m a) -> Fix f -> m a
paraM f (Fix f, a) -> m a
f = f (Fix f, a) -> m a
f (f (Fix f, a) -> m a)
-> (Fix f -> m (f (Fix f, a))) -> Fix f -> m a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (Fix f -> m (Fix f, a)) -> f (Fix f) -> m (f (Fix f, a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\Fix f
x -> (Fix f
x, ) (a -> (Fix f, a)) -> m a -> m (Fix f, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (f (Fix f, a) -> m a) -> Fix f -> m a
forall (f :: * -> *) (m :: * -> *) a.
(Traversable f, Monad m) =>
(f (Fix f, a) -> m a) -> Fix f -> m a
paraM f (Fix f, a) -> m a
f Fix f
x) (f (Fix f) -> m (f (Fix f, a)))
-> (Fix f -> f (Fix f)) -> Fix f -> m (f (Fix f, a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix
cataP :: Functor f => (Fix f -> f a -> a) -> Fix f -> a
cataP :: (Fix f -> f a -> a) -> Fix f -> a
cataP Fix f -> f a -> a
f Fix f
x = Fix f -> f a -> a
f Fix f
x (f a -> a) -> (Fix f -> f a) -> Fix f -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fix f -> a) -> f (Fix f) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Fix f -> f a -> a) -> Fix f -> a
forall (f :: * -> *) a.
Functor f =>
(Fix f -> f a -> a) -> Fix f -> a
cataP Fix f -> f a -> a
f) (f (Fix f) -> f a) -> (Fix f -> f (Fix f)) -> Fix f -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix (Fix f -> a) -> Fix f -> a
forall a b. (a -> b) -> a -> b
$ Fix f
x
cataPM :: (Traversable f, Monad m) => (Fix f -> f a -> m a) -> Fix f -> m a
cataPM :: (Fix f -> f a -> m a) -> Fix f -> m a
cataPM Fix f -> f a -> m a
f Fix f
x = Fix f -> f a -> m a
f Fix f
x (f a -> m a) -> (Fix f -> m (f a)) -> Fix f -> m a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (Fix f -> m a) -> f (Fix f) -> m (f a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Fix f -> f a -> m a) -> Fix f -> m a
forall (f :: * -> *) (m :: * -> *) a.
(Traversable f, Monad m) =>
(Fix f -> f a -> m a) -> Fix f -> m a
cataPM Fix f -> f a -> m a
f) (f (Fix f) -> m (f a)) -> (Fix f -> f (Fix f)) -> Fix f -> m (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix (Fix f -> m a) -> Fix f -> m a
forall a b. (a -> b) -> a -> b
$ Fix f
x
lifted
:: (MonadTransControl u, Monad (u m), Monad m)
=> ((a -> m (StT u b)) -> m (StT u b))
-> (a -> u m b)
-> u m b
lifted :: ((a -> m (StT u b)) -> m (StT u b)) -> (a -> u m b) -> u m b
lifted (a -> m (StT u b)) -> m (StT u b)
f a -> u m b
k =
do
StT u b
lftd <- (Run u -> m (StT u b)) -> u m (StT u b)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run t -> m a) -> t m a
liftWith (\Run u
run -> (a -> m (StT u b)) -> m (StT u b)
f (u m b -> m (StT u b)
Run u
run (u m b -> m (StT u b)) -> (a -> u m b) -> a -> m (StT u b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> u m b
k))
m (StT u b) -> u m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
m (StT t a) -> t m a
restoreT (m (StT u b) -> u m b) -> m (StT u b) -> u m b
forall a b. (a -> b) -> a -> b
$ StT u b -> m (StT u b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure StT u b
lftd
freeToFix :: Functor f => (a -> Fix f) -> Free f a -> Fix f
freeToFix :: (a -> Fix f) -> Free f a -> Fix f
freeToFix a -> Fix f
f = Free f a -> Fix f
go
where
go :: Free f a -> Fix f
go =
(a -> Fix f) -> (f (Free f a) -> Fix f) -> Free f a -> Fix f
forall a b (f :: * -> *).
(a -> b) -> (f (Free f a) -> b) -> Free f a -> b
free
a -> Fix f
f
((f (Free f a) -> Fix f) -> Free f a -> Fix f)
-> (f (Free f a) -> Fix f) -> Free f a -> Fix f
forall a b. (a -> b) -> a -> b
$ f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (f (Fix f) -> Fix f)
-> (f (Free f a) -> f (Fix f)) -> f (Free f a) -> Fix f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Free f a -> Fix f
go (Free f a -> Fix f) -> f (Free f a) -> f (Fix f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
fixToFree :: Functor f => Fix f -> Free f a
fixToFree :: Fix f -> Free f a
fixToFree = f (Free f a) -> Free f a
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (f (Free f a) -> Free f a)
-> (Fix f -> f (Free f a)) -> Fix f -> Free f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix f -> f (Free f a)
forall (f :: * -> *) a. Functor f => Fix f -> f (Free f a)
go
where
go :: Fix f -> f (Free f a)
go (Fix f (Fix f)
f) = f (Free f a) -> Free f a
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (f (Free f a) -> Free f a)
-> (Fix f -> f (Free f a)) -> Fix f -> Free f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix f -> f (Free f a)
go (Fix f -> Free f a) -> f (Fix f) -> f (Free f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Fix f)
f
adi
:: Functor f
=> Transform f a
-> Alg f a
-> Fix f
-> a
adi :: Transform f a -> Alg f a -> Fix f -> a
adi Transform f a
g Alg f a
f = Transform f a
g Transform f a -> Transform f a
forall a b. (a -> b) -> a -> b
$ Alg f a
f Alg f a -> (Fix f -> f a) -> Fix f -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Transform f a -> Alg f a -> Fix f -> a
forall (f :: * -> *) a.
Functor f =>
Transform f a -> Alg f a -> Fix f -> a
adi Transform f a
g Alg f a
f (Fix f -> a) -> f (Fix f) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (f (Fix f) -> f a) -> (Fix f -> f (Fix f)) -> Fix f -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix
adiM
:: ( Traversable t
, Monad m
)
=> Transform t (m a)
-> AlgM t m a
-> Fix t
-> m a
adiM :: Transform t (m a) -> AlgM t m a -> Fix t -> m a
adiM Transform t (m a)
g AlgM t m a
f = Transform t (m a)
g Transform t (m a) -> Transform t (m a)
forall a b. (a -> b) -> a -> b
$ AlgM t m a
f AlgM t m a -> (Fix t -> m (t a)) -> Fix t -> m a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (Fix t -> m a) -> t (Fix t) -> m (t a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Transform t (m a) -> AlgM t m a -> Fix t -> m a
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
Transform t (m a) -> AlgM t m a -> Fix t -> m a
adiM Transform t (m a)
g AlgM t m a
f) (t (Fix t) -> m (t a)) -> (Fix t -> t (Fix t)) -> Fix t -> m (t a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fix t -> t (Fix t)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix
class Has a b where
hasLens :: Lens' a b
instance Has a a where
hasLens :: LensLike' f a a
hasLens a -> f a
f = a -> f a
f
instance Has (a, b) a where
hasLens :: LensLike' f (a, b) a
hasLens = LensLike' f (a, b) a
forall a r b. Lens (a, r) (b, r) a b
_1
instance Has (a, b) b where
hasLens :: LensLike' f (a, b) b
hasLens = LensLike' f (a, b) b
forall r a b. Lens (r, a) (r, b) a b
_2
toEncodingSorted :: A.Value -> A.Encoding
toEncodingSorted :: Value -> Encoding
toEncodingSorted = \case
A.Object Object
m ->
Series -> Encoding
A.pairs
(Series -> Encoding)
-> ([(Text, Value)] -> Series) -> [(Text, Value)] -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Series] -> Series
forall a. Monoid a => [a] -> a
mconcat
([Series] -> Series)
-> ([(Text, Value)] -> [Series]) -> [(Text, Value)] -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((\(Text
k, Value
v) -> Text -> Encoding -> Series
A.pair Text
k (Encoding -> Series) -> Encoding -> Series
forall a b. (a -> b) -> a -> b
$ Value -> Encoding
toEncodingSorted Value
v) ((Text, Value) -> Series) -> [(Text, Value)] -> [Series]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
([(Text, Value)] -> [Series])
-> ([(Text, Value)] -> [(Text, Value)])
-> [(Text, Value)]
-> [Series]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Value) -> Text) -> [(Text, Value)] -> [(Text, Value)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith (Text, Value) -> Text
forall a b. (a, b) -> a
fst
([(Text, Value)] -> Encoding) -> [(Text, Value)] -> Encoding
forall a b. (a -> b) -> a -> b
$ Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
M.toList Object
m
A.Array Array
l -> (Value -> Encoding) -> [Value] -> Encoding
forall a. (a -> Encoding) -> [a] -> Encoding
A.list Value -> Encoding
toEncodingSorted ([Value] -> Encoding) -> [Value] -> Encoding
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
l
Value
v -> Value -> Encoding
forall a. ToJSON a => a -> Encoding
A.toEncoding Value
v
data NixPathEntryType = PathEntryPath | PathEntryURI deriving (Int -> NixPathEntryType -> ShowS
[NixPathEntryType] -> ShowS
NixPathEntryType -> String
(Int -> NixPathEntryType -> ShowS)
-> (NixPathEntryType -> String)
-> ([NixPathEntryType] -> ShowS)
-> Show NixPathEntryType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NixPathEntryType] -> ShowS
$cshowList :: [NixPathEntryType] -> ShowS
show :: NixPathEntryType -> String
$cshow :: NixPathEntryType -> String
showsPrec :: Int -> NixPathEntryType -> ShowS
$cshowsPrec :: Int -> NixPathEntryType -> ShowS
Show, NixPathEntryType -> NixPathEntryType -> Bool
(NixPathEntryType -> NixPathEntryType -> Bool)
-> (NixPathEntryType -> NixPathEntryType -> Bool)
-> Eq NixPathEntryType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NixPathEntryType -> NixPathEntryType -> Bool
$c/= :: NixPathEntryType -> NixPathEntryType -> Bool
== :: NixPathEntryType -> NixPathEntryType -> Bool
$c== :: NixPathEntryType -> NixPathEntryType -> Bool
Eq)
uriAwareSplit :: Text -> [(Text, NixPathEntryType)]
uriAwareSplit :: Text -> [(Text, NixPathEntryType)]
uriAwareSplit Text
txt =
case (Char -> Bool) -> Text -> (Text, Text)
Text.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') Text
txt of
(Text
e1, Text
e2)
| Text -> Bool
Text.null Text
e2 -> [(Text
e1, NixPathEntryType
PathEntryPath)]
| Text
"://" Text -> Text -> Bool
`Text.isPrefixOf` Text
e2 ->
let ((Text
suffix, NixPathEntryType
_) : [(Text, NixPathEntryType)]
path) = Text -> [(Text, NixPathEntryType)]
uriAwareSplit (Int -> Text -> Text
Text.drop Int
3 Text
e2) in
(Text
e1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
suffix, NixPathEntryType
PathEntryURI) (Text, NixPathEntryType)
-> [(Text, NixPathEntryType)] -> [(Text, NixPathEntryType)]
forall a. a -> [a] -> [a]
: [(Text, NixPathEntryType)]
path
| Bool
otherwise -> (Text
e1, NixPathEntryType
PathEntryPath) (Text, NixPathEntryType)
-> [(Text, NixPathEntryType)] -> [(Text, NixPathEntryType)]
forall a. a -> [a] -> [a]
: Text -> [(Text, NixPathEntryType)]
uriAwareSplit (Int -> Text -> Text
Text.drop Int
1 Text
e2)
alterF
:: (Eq k, Hashable k, Functor f)
=> (Maybe v -> f (Maybe v))
-> k
-> HashMap k v
-> f (HashMap k v)
alterF :: (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)
alterF Maybe v -> f (Maybe v)
f k
k HashMap k v
m =
HashMap k v -> (v -> HashMap k v) -> Maybe v -> HashMap k v
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(k -> HashMap k v -> HashMap k v
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
M.delete k
k HashMap k v
m)
(\ v
v -> k -> v -> HashMap k v -> HashMap k v
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert k
k v
v HashMap k v
m)
(Maybe v -> HashMap k v) -> f (Maybe v) -> f (HashMap k v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe v -> f (Maybe v)
f (k -> HashMap k v -> Maybe v
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup k
k HashMap k v
m)
list
:: Foldable t
=> b -> (t a -> b) -> t a -> b
list :: b -> (t a -> b) -> t a -> b
list b
e t a -> b
f t a
l =
b -> b -> Bool -> b
forall a. a -> a -> Bool -> a
bool
(t a -> b
f t a
l)
b
e
(t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
l)
{-# inline list #-}
free :: (a -> b) -> (f (Free f a) -> b) -> Free f a -> b
free :: (a -> b) -> (f (Free f a) -> b) -> Free f a -> b
free a -> b
fP f (Free f a) -> b
fF Free f a
fr =
case Free f a
fr of
Pure a
a -> a -> b
fP a
a
Free f (Free f a)
fa -> f (Free f a) -> b
fF f (Free f a)
fa
{-# inline free #-}
whenTrue :: (Monoid a)
=> a -> Bool -> a
whenTrue :: a -> Bool -> a
whenTrue =
a -> a -> Bool -> a
forall a. a -> a -> Bool -> a
bool
a
forall a. Monoid a => a
mempty
{-# inline whenTrue #-}
whenFalse :: (Monoid a)
=> a -> Bool -> a
whenFalse :: a -> Bool -> a
whenFalse a
f =
a -> a -> Bool -> a
forall a. a -> a -> Bool -> a
bool
a
f
a
forall a. Monoid a => a
mempty
{-# inline whenFalse #-}
whenFree :: (Monoid b)
=> (f (Free f a) -> b) -> Free f a -> b
whenFree :: (f (Free f a) -> b) -> Free f a -> b
whenFree =
(a -> b) -> (f (Free f a) -> b) -> Free f a -> b
forall a b (f :: * -> *).
(a -> b) -> (f (Free f a) -> b) -> Free f a -> b
free
a -> b
forall a. Monoid a => a
mempty
{-# inline whenFree #-}
whenPure :: (Monoid b)
=> (a -> b) -> Free f a -> b
whenPure :: (a -> b) -> Free f a -> b
whenPure a -> b
f =
(a -> b) -> (f (Free f a) -> b) -> Free f a -> b
forall a b (f :: * -> *).
(a -> b) -> (f (Free f a) -> b) -> Free f a -> b
free
a -> b
f
f (Free f a) -> b
forall a. Monoid a => a
mempty
{-# inline whenPure #-}
both :: (a -> b) -> (a, a) -> (b, b)
both :: (a -> b) -> (a, a) -> (b, b)
both a -> b
f (a
x,a
y) = (a -> b
f a
x, a -> b
f a
y)
{-# inline both #-}
dup :: a -> (a, a)
dup :: a -> (a, a)
dup a
x = (a
x, a
x)
{-# inline dup #-}
mapPair :: (a -> c, b -> d) -> (a,b) -> (c,d)
mapPair :: (a -> c, b -> d) -> (a, b) -> (c, d)
mapPair ~(a -> c
f,b -> d
g) ~(a
a,b
b) = (a -> c
f a
a, b -> d
g b
b)
{-# inline mapPair #-}
stub :: (Applicative f, Monoid a) => f a
stub :: f a
stub = a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty
{-# inline stub #-}