{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}

{-# OPTIONS_GHC -Wno-missing-signatures #-}

module Nix.Utils (module Nix.Utils, module X) where

import           Control.Arrow                  ( (&&&) )
import           Control.Monad
import           Control.Monad.Fix
import           Control.Monad.Free
import           Control.Monad.Trans.Control    ( MonadTransControl(..) )
import qualified Data.Aeson                    as A
import qualified Data.Aeson.Encoding           as A
import           Data.Fix
import           Data.Hashable
import           Data.HashMap.Lazy              ( HashMap )
import qualified Data.HashMap.Lazy             as M
import           Data.List                      ( sortOn )
import           Data.Monoid                    ( Endo )
import           Data.Text                      ( Text )
import qualified Data.Text                     as Text
import qualified Data.Vector                   as V
import           Lens.Family2                  as X
import           Lens.Family2.Stock             ( _1
                                                , _2
                                                )
import           Lens.Family2.TH

#if ENABLE_TRACING
import           Debug.Trace as X
#else
import           Prelude                       as X
                                         hiding ( putStr
                                                , putStrLn
                                                , print
                                                )
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
traceM :: Monad m => String -> m ()
traceM :: String -> m ()
traceM = m () -> String -> m ()
forall a b. a -> b -> a
const (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
#endif

$(makeLensesBy (\n -> Just ("_" ++ n)) ''Fix)

type DList a = Endo [a]

type AttrSet = HashMap Text

-- | An f-algebra defines how to reduced the fixed-point of a functor to a
--   value.
type Alg f a = f a -> a

type AlgM f m a = f a -> m a

-- | An "transform" here is a modification of a catamorphism.
type Transform f a = (Fix f -> a) -> Fix f -> a

(<&>) :: Functor f => f a -> (a -> c) -> f c
<&> :: f a -> (a -> c) -> f c
(<&>) = ((a -> c) -> f a -> f c) -> f a -> (a -> c) -> f c
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> c) -> f a -> f c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
(<$>)

(??) :: Functor f => f (a -> b) -> a -> f b
fab :: f (a -> b)
fab ?? :: f (a -> b) -> a -> f b
?? a :: a
a = ((a -> b) -> b) -> f (a -> b) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
a) f (a -> b)
fab

loeb :: Functor f => f (f a -> a) -> f a
loeb :: f (f a -> a) -> f a
loeb x :: f (f a -> a)
x = f a
go where go :: 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
fmap ((f a -> a) -> f a -> a
forall a b. (a -> b) -> a -> b
$ f a
go) 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 f :: 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
$ \a :: t a
a -> ((t a -> m a) -> m a) -> t (t a -> m a) -> m (t a)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((t a -> m a) -> t a -> m a
forall a b. (a -> b) -> a -> b
$ t a
a) t (t a -> m a)
f

para :: Functor f => (f (Fix f, a) -> a) -> Fix f -> a
para :: (f (Fix f, a) -> a) -> Fix f -> a
para f :: 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 :: 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 (\x :: 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 f :: Fix f -> f a -> a
f x :: 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 f :: Fix f -> f a -> m a
f x :: 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

transport :: Functor g => (forall x . f x -> g x) -> Fix f -> Fix g
transport :: (forall x. f x -> g x) -> Fix f -> Fix g
transport f :: forall x. f x -> g x
f (Fix x :: f (Fix f)
x) = g (Fix g) -> Fix g
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (g (Fix g) -> Fix g) -> g (Fix g) -> Fix g
forall a b. (a -> b) -> a -> b
$ (Fix f -> Fix g) -> g (Fix f) -> g (Fix g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall x. f x -> g x) -> Fix f -> Fix g
forall (g :: * -> *) (f :: * -> *).
Functor g =>
(forall x. f x -> g x) -> Fix f -> Fix g
transport forall x. f x -> g x
f) (f (Fix f) -> g (Fix f)
forall x. f x -> g x
f f (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 f :: (a -> m (StT u b)) -> m (StT u b)
f k :: a -> u m b
k = (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 :: 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)) u m (StT u b) -> (StT u b -> u m b) -> u m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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)
-> (StT u b -> m (StT u b)) -> StT u b -> u m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StT u b -> m (StT u b)
forall (m :: * -> *) a. Monad m => a -> m a
return

freeToFix :: Functor f => (a -> Fix f) -> Free f a -> Fix f
freeToFix :: (a -> Fix f) -> Free f a -> Fix f
freeToFix f :: a -> Fix f
f = Free f a -> Fix f
go
 where
  go :: Free f a -> Fix f
go (Pure a :: a
a) = a -> Fix f
f a
a
  go (Free v :: f (Free f a)
v) = f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix ((Free f a -> Fix f) -> f (Free f a) -> f (Fix f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Free f a -> Fix f
go f (Free f a)
v)

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 :: f (Fix f)
f) = (Fix f -> Free f a) -> f (Fix f) -> f (Free f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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) f (Fix f)
f

-- | adi is Abstracting Definitional Interpreters:
--
--     https://arxiv.org/abs/1707.04755
--
--   Essentially, it does for evaluation what recursion schemes do for
--   representation: allows threading layers through existing structure, only
--   in this case through behavior.
adi :: Functor f => (f a -> a) -> ((Fix f -> a) -> Fix f -> a) -> Fix f -> a
adi :: (f a -> a) -> ((Fix f -> a) -> Fix f -> a) -> Fix f -> a
adi f :: f a -> a
f g :: (Fix f -> a) -> Fix f -> a
g = (Fix f -> a) -> Fix f -> a
g (f a -> a
f (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 ((f a -> a) -> ((Fix f -> a) -> Fix f -> a) -> Fix f -> a
forall (f :: * -> *) a.
Functor f =>
(f a -> a) -> ((Fix f -> a) -> Fix f -> a) -> Fix f -> a
adi f a -> a
f (Fix f -> a) -> Fix f -> a
g) (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)
  => (t a -> m a)
  -> ((Fix t -> m a) -> Fix t -> m a)
  -> Fix t
  -> m a
adiM :: (t a -> m a) -> ((Fix t -> m a) -> Fix t -> m a) -> Fix t -> m a
adiM f :: t a -> m a
f g :: (Fix t -> m a) -> Fix t -> m a
g = (Fix t -> m a) -> Fix t -> m a
g ((t a -> m a
f (t a -> m a) -> (t (Fix t) -> m (t a)) -> t (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 ((t a -> m a) -> ((Fix t -> m a) -> Fix t -> m a) -> Fix t -> m a
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
(t a -> m a) -> ((Fix t -> m a) -> Fix t -> m a) -> Fix t -> m a
adiM t a -> m a
f (Fix t -> m a) -> Fix t -> m a
g)) (t (Fix t) -> m a) -> (Fix t -> t (Fix t)) -> Fix t -> m 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 f :: 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 m :: 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, Value) -> Series) -> [(Text, Value)] -> [Series]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(k :: Text
k, v :: 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)] -> [(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]
sortOn (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 l :: 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
  v :: 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)

-- | @NIX_PATH@ is colon-separated, but can also contain URLs, which have a colon
-- (i.e. @https://...@)
uriAwareSplit :: Text -> [(Text, NixPathEntryType)]
uriAwareSplit :: Text -> [(Text, NixPathEntryType)]
uriAwareSplit = Text -> [(Text, NixPathEntryType)]
go where
  go :: Text -> [(Text, NixPathEntryType)]
go str :: Text
str = case (Char -> Bool) -> Text -> (Text, Text)
Text.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ':') Text
str of
    (e1 :: Text
e1, e2 :: Text
e2)
      | Text -> Bool
Text.null Text
e2
      -> [(Text
e1, NixPathEntryType
PathEntryPath)]
      | String -> Text
Text.pack "://" Text -> Text -> Bool
`Text.isPrefixOf` Text
e2
      -> let ((suffix :: Text
suffix, _) : path :: [(Text, NixPathEntryType)]
path) = Text -> [(Text, NixPathEntryType)]
go (Int -> Text -> Text
Text.drop 3 Text
e2)
         in  (Text
e1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack "://" 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)]
go (Int -> Text -> Text
Text.drop 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 f :: Maybe v -> f (Maybe v)
f k :: k
k m :: HashMap k v
m = 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) f (Maybe v) -> (Maybe v -> HashMap k v) -> f (HashMap k v)
forall (f :: * -> *) a c. Functor f => f a -> (a -> c) -> f c
<&> \case
  Nothing -> 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
  Just v :: 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