Value.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

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

module Nix.Value where

import           Control.Comonad
import           Control.Exception
import           Control.Monad
import           Control.Monad.Free
import           Control.Monad.Trans.Class
import qualified Data.Aeson                    as A
import           Data.Functor.Classes
import           Data.HashMap.Lazy              ( HashMap )
import           Data.Text                      ( Text )
import           Data.Typeable                  ( Typeable )
import           GHC.Generics
import           Lens.Family2
import           Lens.Family2.Stock
import           Lens.Family2.TH
import           Nix.Atoms
import           Nix.Expr.Types
import           Nix.Expr.Types.Annotated
import           Nix.String
import           Nix.Thunk
import           Nix.Utils

-- | An 'NValue' is the most reduced form of an 'NExpr' after evaluation is
--   completed. 's' is related to the type of errors that might occur during
--   construction or use of a value.
data NValueF p m r
    = NVConstantF NAtom
     -- | A string has a value and a context, which can be used to record what a
     -- string has been build from
    | NVStrF NixString
    | NVPathF FilePath
    | NVListF [r]
    | NVSetF (AttrSet r) (AttrSet SourcePos)
    | NVClosureF (Params ()) (m p -> m r)
      -- ^ A function is a closed set of parameters representing the "call
      --   signature", used at application time to check the type of arguments
      --   passed to the function. Since it supports default values which may
      --   depend on other values within the final argument set, this
      --   dependency is represented as a set of pending evaluations. The
      --   arguments are finally normalized into a set which is passed to the
      --   function.
      --
      --   Note that 'm r' is being used here because effectively a function
      --   and its set of default arguments is "never fully evaluated". This
      --   enforces in the type that it must be re-evaluated for each call.
    | NVBuiltinF String (m p -> m r)
      -- ^ A builtin function is itself already in normal form. Also, it may
      --   or may not choose to evaluate its argument in the production of a
      --   result.
    deriving (Generic, Typeable, Functor)

-- | This 'Foldable' instance only folds what the value actually is known to
--   contain at time of fold.
instance Foldable (NValueF p m) where
  foldMap f = \case
    NVConstantF _  -> mempty
    NVStrF      _  -> mempty
    NVPathF     _  -> mempty
    NVListF     l  -> foldMap f l
    NVSetF     s _ -> foldMap f s
    NVClosureF _ _ -> mempty
    NVBuiltinF _ _ -> mempty

lmapNValueF :: Functor m => (b -> a) -> NValueF a m r -> NValueF b m r
lmapNValueF f = \case
  NVConstantF a  -> NVConstantF a
  NVStrF      s  -> NVStrF s
  NVPathF     p  -> NVPathF p
  NVListF     l  -> NVListF l
  NVSetF     s p -> NVSetF s p
  NVClosureF p g -> NVClosureF p (g . fmap f)
  NVBuiltinF s g -> NVBuiltinF s (g . fmap f)

hoistNValueF
  :: (forall x . n x -> m x)
  -> (forall x . m x -> n x)
  -> NValueF p m a
  -> NValueF p n a
hoistNValueF run lft = \case
  NVConstantF a  -> NVConstantF a
  NVStrF      s  -> NVStrF s
  NVPathF     p  -> NVPathF p
  NVListF     l  -> NVListF l
  NVSetF     s p -> NVSetF s p
  NVClosureF p g -> NVClosureF p (lft . g . run)
  NVBuiltinF s g -> NVBuiltinF s (lft . g . run)

sequenceNValueF
  :: (Functor n, Monad m, Applicative n)
  => (forall x . n x -> m x)
  -> NValueF p m (n a)
  -> n (NValueF p m a)
sequenceNValueF transform = \case
  NVConstantF a  -> pure $ NVConstantF a
  NVStrF      s  -> pure $ NVStrF s
  NVPathF     p  -> pure $ NVPathF p
  NVListF     l  -> NVListF <$> sequenceA l
  NVSetF     s p -> NVSetF <$> sequenceA s <*> pure p
  NVClosureF p g -> pure $ NVClosureF p (transform <=< g)
  NVBuiltinF s g -> pure $ NVBuiltinF s (transform <=< g)

bindNValueF
  :: (Monad m, Monad n)
  => (forall x . n x -> m x)
  -> (a -> n b)
  -> NValueF p m a
  -> n (NValueF p m b)
bindNValueF transform f = \case
  NVConstantF a  -> pure $ NVConstantF a
  NVStrF      s  -> pure $ NVStrF s
  NVPathF     p  -> pure $ NVPathF p
  NVListF     l  -> NVListF <$> traverse f l
  NVSetF     s p -> NVSetF <$> traverse f s <*> pure p
  NVClosureF p g -> pure $ NVClosureF p (transform . f <=< g)
  NVBuiltinF s g -> pure $ NVBuiltinF s (transform . f <=< g)

liftNValueF
  :: (MonadTrans u, Monad m)
  => (forall x . u m x -> m x)
  -> NValueF p m a
  -> NValueF p (u m) a
liftNValueF run = hoistNValueF run lift

unliftNValueF
  :: (MonadTrans u, Monad m)
  => (forall x . u m x -> m x)
  -> NValueF p (u m) a
  -> NValueF p m a
unliftNValueF run = hoistNValueF lift run

type MonadDataContext f (m :: * -> *)
  = (Comonad f, Applicative f, Traversable f, Monad m)

-- | At the time of constructor, the expected arguments to closures are values
--   that may contain thunks. The type of such thunks are fixed at that time.
newtype NValue' t f m a = NValue { _nValue :: f (NValueF (NValue t f m) m a) }
    deriving (Generic, Typeable, Functor, Foldable)

instance Show r => Show (NValueF p m r) where
  showsPrec = flip go   where
    go (NVConstantF atom  ) = showsCon1 "NVConstant" atom
    go (NVStrF      ns    ) = showsCon1 "NVStr" (hackyStringIgnoreContext ns)
    go (NVListF     lst   ) = showsCon1 "NVList" lst
    go (NVSetF     attrs _) = showsCon1 "NVSet" attrs
    go (NVClosureF p     _) = showsCon1 "NVClosure" p
    go (NVPathF p         ) = showsCon1 "NVPath" p
    go (NVBuiltinF name _ ) = showsCon1 "NVBuiltin" name

    showsCon1 :: Show a => String -> a -> Int -> String -> String
    showsCon1 con a d =
      showParen (d > 10) $ showString (con ++ " ") . showsPrec 11 a

instance (Comonad f, Show a) => Show (NValue' t f m a) where
  show (NValue (extract -> v)) = show v

instance Comonad f => Show1 (NValue' t f m) where
  liftShowsPrec sp sl p = \case
    NVConstant atom -> showsUnaryWith showsPrec "NVConstantF" p atom
    NVStr ns ->
      showsUnaryWith showsPrec "NVStrF" p (hackyStringIgnoreContext ns)
    NVList lst       -> showsUnaryWith (liftShowsPrec sp sl) "NVListF" p lst
    NVSet attrs _    -> showsUnaryWith (liftShowsPrec sp sl) "NVSetF" p attrs
    NVPath path      -> showsUnaryWith showsPrec "NVPathF" p path
    NVClosure c    _ -> showsUnaryWith showsPrec "NVClosureF" p c
    NVBuiltin name _ -> showsUnaryWith showsPrec "NVBuiltinF" p name
    _                -> error "Pattern synonyms mask coverage"

type NValue t f m = NValue' t f m t

sequenceNValue
  :: (Functor n, Traversable f, Monad m, Applicative n)
  => (forall x . n x -> m x)
  -> NValue' t f m (n a)
  -> n (NValue' t f m a)
sequenceNValue transform (NValue v) =
  NValue <$> traverse (sequenceNValueF transform) v

bindNValue
  :: (Traversable f, Monad m, Monad n)
  => (forall x . n x -> m x)
  -> (a -> n b)
  -> NValue' t f m a
  -> n (NValue' t f m b)
bindNValue transform f (NValue v) =
  NValue <$> traverse (bindNValueF transform f) v

hoistNValue
  :: (Functor m, Functor n, Functor f)
  => (forall x . n x -> m x)
  -> (forall x . m x -> n x)
  -> NValue' t f m a
  -> NValue' t f n a
hoistNValue run lft (NValue v) =
  NValue (fmap (lmapNValueF (hoistNValue lft run) . hoistNValueF run lft) v)

liftNValue
  :: (MonadTrans u, Monad m, Functor (u m), Functor f)
  => (forall x . u m x -> m x)
  -> NValue' t f m a
  -> NValue' t f (u m) a
liftNValue run = hoistNValue run lift

unliftNValue
  :: (MonadTrans u, Monad m, Functor (u m), Functor f)
  => (forall x . u m x -> m x)
  -> NValue' t f (u m) a
  -> NValue' t f m a
unliftNValue run = hoistNValue lift run

-- | An 'NValueNF' is a fully evaluated value in normal form. An 'NValue f t m' is
--   a value in head normal form, where only the "top layer" has been
--   evaluated. An action of type 'm (NValue f t m)' is a pending evualation that
--   has yet to be performed. An 't' is either a pending evaluation, or
--   a value in head normal form. A 'NThunkSet' is a set of mappings from keys
--   to thunks.
--
--   The 'Free' structure is used here to represent the possibility that
--   cycles may appear during normalization.

type NValueNF t f m = Free (NValue' t f m) t

iterNValue
  :: forall t f m a r
   . MonadDataContext f m
  => (a -> (NValue' t f m a -> r) -> r)
  -> (NValue' t f m r -> r)
  -> NValue' t f m a
  -> r
iterNValue k f = f . fmap (\a -> k a (iterNValue k f))

iterNValueM
  :: (MonadDataContext f m, Monad n)
  => (forall x . n x -> m x)
  -> (a -> (NValue' t f m a -> n r) -> n r)
  -> (NValue' t f m r -> n r)
  -> NValue' t f m a
  -> n r
iterNValueM transform k f =
  f <=< bindNValue transform (\a -> k a (iterNValueM transform k f))

iterNValueNF
  :: MonadDataContext f m
  => (t -> r)
  -> (NValue' t f m r -> r)
  -> NValueNF t f m
  -> r
iterNValueNF k f = iter f . fmap k

iterNValueNFM
  :: forall f m n t r
   . (MonadDataContext f m, Monad n)
  => (forall x . n x -> m x)
  -> (t -> n r)
  -> (NValue' t f m (n r) -> n r)
  -> NValueNF t f m
  -> n r
iterNValueNFM transform k f v =
  iterM f =<< go (fmap k v)
  where
  go (Pure a ) = Pure <$> a
  go (Free fa) = Free <$> bindNValue transform go fa

nValueFromNF
  :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
  => NValueNF t f m
  -> NValue t f m
nValueFromNF = iterNValueNF f (fmap wrapValue)
 where
  f t = query t cyc id
  cyc = nvStr (principledMakeNixStringWithoutContext "<CYCLE>")

nValueToNF
  :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
  => (t -> (NValue t f m -> NValueNF t f m) -> NValueNF t f m)
  -> NValue t f m
  -> NValueNF t f m
nValueToNF k = iterNValue k Free

nValueToNFM
  :: (MonadDataContext f m, Monad n)
  => (forall x . n x -> m x)
  -> (t -> (NValue t f m -> n (NValueNF t f m)) -> n (NValueNF t f m))
  -> NValue t f m
  -> n (NValueNF t f m)
nValueToNFM transform k = iterNValueM transform k $ pure . Free

pattern NVConstant x <- NValue (extract -> NVConstantF x)
pattern NVConstantNF x <- Free (NValue (extract -> NVConstantF x))

nvConstant :: Applicative f => NAtom -> NValue t f m
nvConstant x = NValue (pure (NVConstantF x))
nvConstantNF :: Applicative f => NAtom -> NValueNF t f m
nvConstantNF x = Free (NValue (pure (NVConstantF x)))

pattern NVStr ns <- NValue (extract -> NVStrF ns)
pattern NVStrNF ns <- Free (NValue (extract -> NVStrF ns))

nvStr :: Applicative f => NixString -> NValue t f m
nvStr ns = NValue (pure (NVStrF ns))
nvStrNF :: Applicative f => NixString -> NValueNF t f m
nvStrNF ns = Free (NValue (pure (NVStrF ns)))

pattern NVPath x <- NValue (extract -> NVPathF x)
pattern NVPathNF x <- Free (NValue (extract -> NVPathF x))

nvPath :: Applicative f => FilePath -> NValue t f m
nvPath x = NValue (pure (NVPathF x))
nvPathNF :: Applicative f => FilePath -> NValueNF t f m
nvPathNF x = Free (NValue (pure (NVPathF x)))

pattern NVList l <- NValue (extract -> NVListF l)
pattern NVListNF l <- Free (NValue (extract -> NVListF l))

nvList :: Applicative f => [t] -> NValue t f m
nvList l = NValue (pure (NVListF l))
nvListNF :: Applicative f => [NValueNF t f m] -> NValueNF t f m
nvListNF l = Free (NValue (pure (NVListF l)))

pattern NVSet s x <- NValue (extract -> NVSetF s x)
pattern NVSetNF s x <- Free (NValue (extract -> NVSetF s x))

nvSet :: Applicative f
      => HashMap Text t -> HashMap Text SourcePos -> NValue t f m
nvSet s x = NValue (pure (NVSetF s x))
nvSetNF :: Applicative f
        => HashMap Text (NValueNF t f m) -> HashMap Text SourcePos -> NValueNF t f m
nvSetNF s x = Free (NValue (pure (NVSetF s x)))

pattern NVClosure x f <- NValue (extract -> NVClosureF x f)
pattern NVClosureNF x f <- Free (NValue (extract -> NVClosureF x f))

nvClosure :: Applicative f
          => Params () -> (m (NValue t f m) -> m t) -> NValue t f m
nvClosure x f = NValue (pure (NVClosureF x f))
nvClosureNF :: Applicative f
            => Params () -> (m (NValue t f m) -> m (NValueNF t f m)) -> NValueNF t f m
nvClosureNF x f = Free (NValue (pure (NVClosureF x f)))

pattern NVBuiltin name f <- NValue (extract -> NVBuiltinF name f)
pattern NVBuiltinNF name f <- Free (NValue (extract -> NVBuiltinF name f))

nvBuiltin :: Applicative f
          => String -> (m (NValue t f m) -> m t) -> NValue t f m
nvBuiltin name f = NValue (pure (NVBuiltinF name f))
nvBuiltinNF :: Applicative f
            => String -> (m (NValue t f m) -> m (NValueNF t f m)) -> NValueNF t f m
nvBuiltinNF name f = Free (NValue (pure (NVBuiltinF name f)))

builtin
  :: forall m f t
   . (MonadThunk t m (NValue t f m), MonadDataContext f m)
  => String
  -> (m (NValue t f m) -> m (NValue t f m))
  -> m (NValue t f m)
builtin name f = return $ nvBuiltin name $ \a -> thunk $ f a

builtin2
  :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
  => String
  -> (m (NValue t f m) -> m (NValue t f m) -> m (NValue t f m))
  -> m (NValue t f m)
builtin2 name f = builtin name $ \a -> builtin name $ \b -> f a b

builtin3
  :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
  => String
  -> (  m (NValue t f m)
     -> m (NValue t f m)
     -> m (NValue t f m)
     -> m (NValue t f m)
     )
  -> m (NValue t f m)
builtin3 name f =
  builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c

isClosureNF :: Comonad f => NValueNF t f m -> Bool
isClosureNF NVClosureNF{} = True
isClosureNF _             = False

data TStringContext = NoContext | HasContext
  deriving Show

data ValueType
    = TInt
    | TFloat
    | TBool
    | TNull
    | TString TStringContext
    | TList
    | TSet
    | TClosure
    | TPath
    | TBuiltin
    deriving Show

valueType :: NValueF a m r -> ValueType
valueType = \case
  NVConstantF a -> case a of
    NInt   _ -> TInt
    NFloat _ -> TFloat
    NBool  _ -> TBool
    NNull    -> TNull
  NVStrF ns | stringHasContext ns -> TString HasContext
            | otherwise           -> TString NoContext
  NVListF{}    -> TList
  NVSetF{}     -> TSet
  NVClosureF{} -> TClosure
  NVPathF{}    -> TPath
  NVBuiltinF{} -> TBuiltin

describeValue :: ValueType -> String
describeValue = \case
  TInt               -> "an integer"
  TFloat             -> "a float"
  TBool              -> "a boolean"
  TNull              -> "a null"
  TString NoContext  -> "a string"
  TString HasContext -> "a string with context"
  TList              -> "a list"
  TSet               -> "an attr set"
  TClosure           -> "a function"
  TPath              -> "a path"
  TBuiltin           -> "a builtin function"

data ValueFrame t f m
    = ForcingThunk
    | ConcerningValue (NValue t f m)
    | Comparison (NValue t f m) (NValue t f m)
    | Addition (NValue t f m) (NValue t f m)
    | Multiplication (NValue t f m) (NValue t f m)
    | Division (NValue t f m) (NValue t f m)
    | Coercion ValueType ValueType
    | CoercionToJson (NValue t f m)
    | CoercionFromJson A.Value
    | ExpectationNF ValueType (NValueNF t f m)
    | Expectation ValueType (NValue t f m)
    deriving (Show, Typeable)

type MonadDataErrorContext t f m
  = (Show t, Typeable t, Typeable m, Typeable f, MonadDataContext f m)

instance MonadDataErrorContext t f m => Exception (ValueFrame t f m)

$(makeTraversals ''NValueF)
$(makeLenses ''NValue')

key
  :: (Traversable f, Applicative g)
  => VarName
  -> LensLike' g (NValue' t f m a) (Maybe a)
key k = nValue . traverse . _NVSetF . _1 . hashAt k