{-# language AllowAmbiguousTypes #-}
{-# language CPP #-}
{-# language ConstraintKinds #-}
{-# language PartialTypeSignatures #-}
{-# language RankNTypes #-}
{-# language TypeFamilies #-}
{-# language UndecidableInstances #-}

{-# options_ghc -Wno-orphans #-}
{-# options_ghc -fno-warn-name-shadowing #-}


module Nix.Exec where

import           Nix.Prelude             hiding ( putStr
                                                , putStrLn
                                                , print
                                                )
import           GHC.Exception                  ( ErrorCall(ErrorCall) )
import           Control.Monad.Catch     hiding ( catchJust )
import           Control.Monad.Fix
import           Data.Fix
import qualified Data.HashMap.Lazy             as M
import qualified Data.List.NonEmpty            as NE
import qualified Data.Text                     as Text
import           Nix.Atoms
import           Nix.Cited
import           Nix.Convert
import           Nix.Effects
import           Nix.Eval                      as Eval
import           Nix.Expr.Types
import           Nix.Expr.Types.Annotated
import           Nix.Frames
import           Nix.Options
import           Nix.Pretty
import           Nix.Render
import           Nix.Scope
import           Nix.String
import           Nix.String.Coerce
import           Nix.Thunk
import           Nix.Value
import           Nix.Value.Equal
import           Nix.Value.Monad
import           Prettyprinter
import qualified Text.Show.Pretty              as PS

#ifdef MIN_VERSION_ghc_datasize 
import           GHC.DataSize
#endif

type MonadCited t f m =
  ( HasCitations m (NValue t f m) t
  , HasCitations1 m (NValue t f m) f
  , MonadDataContext f m
  )

mkNVConstantWithProvenance
  :: MonadCited t f m
  => Scopes m (NValue t f m)
  -> SrcSpan
  -> NAtom
  -> NValue t f m
mkNVConstantWithProvenance scopes span x =
  addProvenance (Provenance scopes . NConstantAnnF span $ x) $ mkNVConstant x

mkNVStrWithProvenance
  :: MonadCited t f m
  => Scopes m (NValue t f m)
  -> SrcSpan
  -> NixString
  -> NValue t f m
mkNVStrWithProvenance scopes span x =
  addProvenance (Provenance scopes . NStrAnnF span . DoubleQuoted . one . Plain . ignoreContext $ x) $ mkNVStr x

mkNVPathWithProvenance
  :: MonadCited t f m
  => Scopes m (NValue t f m)
  -> SrcSpan
  -> Path
  -> Path
  -> NValue t f m
mkNVPathWithProvenance scope span lit real =
  addProvenance (Provenance scope . NLiteralPathAnnF span $ lit) $ mkNVPath real

mkNVClosureWithProvenance
  :: MonadCited t f m
  => Scopes m (NValue t f m)
  -> SrcSpan
  -> Params ()
  -> (NValue t f m -> m (NValue t f m))
  -> NValue t f m
mkNVClosureWithProvenance scopes span x f =
  addProvenance (Provenance scopes $ NAbsAnnF span (Nothing <$ x) Nothing) $ mkNVClosure x f

mkNVUnaryOpWithProvenance
  :: MonadCited t f m
  => Scopes m (NValue t f m)
  -> SrcSpan
  -> NUnaryOp
  -> Maybe (NValue t f m)
  -> NValue t f m
  -> NValue t f m
mkNVUnaryOpWithProvenance scope span op val =
  addProvenance (Provenance scope $ NUnaryAnnF span op val)

mkNVBinaryOpWithProvenance
  :: MonadCited t f m
  => Scopes m (NValue t f m)
  -> SrcSpan
  -> NBinaryOp
  -> Maybe (NValue t f m)
  -> Maybe (NValue t f m)
  -> NValue t f m
  -> NValue t f m
mkNVBinaryOpWithProvenance scope span op lval rval =
  addProvenance (Provenance scope $ NBinaryAnnF span op lval rval)

type MonadCitedThunks t f m =
  ( MonadThunk t m (NValue t f m)
  , MonadDataErrorContext t f m
  , HasCitations m (NValue t f m) t
  , HasCitations1 m (NValue t f m) f
  )

type MonadNix e t f m =
  ( Has e SrcSpan
  , Has e Options
  , Scoped (NValue t f m) m
  , Framed e m
  , MonadFix m
  , MonadCatch m
  , MonadThrow m
  , Alternative m
  , MonadEffects t f m
  , MonadCitedThunks t f m
  , MonadValue (NValue t f m) m
  )

data ExecFrame t f m = Assertion SrcSpan (NValue t f m)
  deriving (Show, Typeable)

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

nverr :: forall e t f s m a . (MonadNix e t f m, Exception s) => s -> m a
nverr = evalError @(NValue t f m)

askSpan :: forall e m . (MonadReader e m, Has e SrcSpan) => m SrcSpan
askSpan = askLocal

wrapExprLoc :: SrcSpan -> NExprLocF r -> NExprLoc
wrapExprLoc span x = Fix $ NSymAnn span "<?>" <$ x
{-# inline wrapExprLoc #-}

--  2021-01-07: NOTE: This instance belongs to be beside MonadEval type class.
-- Currently instance is stuck in orphanage between the requirements to be MonadEval, aka Eval stage, and emposed requirement to be MonadNix (Execution stage). MonadNix constraint tries to put the cart before horse and seems superflous, since Eval in Nix also needs and can throw exceptions. It is between `nverr` and `evalError`.
instance MonadNix e t f m => MonadEval (NValue t f m) m where
  freeVariable var =
    nverr @e @t @f $ ErrorCall $ toString @Text $ "Undefined variable '" <> coerce var <> "'"

  synHole name =
    do
      span  <- askSpan
      scope <- askScopes
      evalError @(NValue t f m) $ SynHole $
        SynHoleInfo
          { _synHoleInfo_expr  = NSynHoleAnn span name
          , _synHoleInfo_scope = scope
          }


  attrMissing ks ms =
    evalError @(NValue t f m) $ ErrorCall $ toString $
      maybe
        ("Inheriting unknown attribute: " <> attr)
        (\ s -> "Could not look up attribute " <> attr <> " in " <> show (prettyNValue s))
        ms
       where
        attr = Text.intercalate "." $ NE.toList $ coerce ks

  evalCurPos =
    do
      scope                  <- askScopes
      span@(SrcSpan delta _) <- askSpan
      addProvenance @_ @_ @(NValue t f m)
        (Provenance scope . NSymAnnF span $ coerce @Text "__curPos") <$>
          toValue delta

  evaledSym name val =
    do
      scope <- askScopes
      span  <- askSpan
      pure $
        addProvenance @_ @_ @(NValue t f m)
          (Provenance scope $ NSymAnnF span name)
          val

  evalConstant c =
    do
      scope <- askScopes
      span  <- askSpan
      pure $ mkNVConstantWithProvenance scope span c

  evalString =
    maybe
      (nverr $ ErrorCall "Failed to assemble string")
      (\ ns ->
        do
          scope <- askScopes
          span  <- askSpan
          pure $ mkNVStrWithProvenance scope span ns
      )
      <=< assembleString

  evalLiteralPath p =
    do
      scope <- askScopes
      span  <- askSpan
      mkNVPathWithProvenance scope span p <$> toAbsolutePath @t @f @m p

  evalEnvPath p =
    do
      scope <- askScopes
      span  <- askSpan
      mkNVPathWithProvenance scope span p <$> findEnvPath @t @f @m (coerce p)

  evalUnary op arg =
    do
      scope <- askScopes
      span  <- askSpan
      execUnaryOp scope span op arg

  evalBinary op larg rarg =
    do
      scope <- askScopes
      span  <- askSpan
      execBinaryOp scope span op larg rarg

  evalWith c b =
    do
      scope <- askScopes
      span  <- askSpan
      let f = join $ addProvenance . Provenance scope . NWithAnnF span Nothing . pure
      f <$> evalWithAttrSet c b

  evalIf c tVal fVal =
    do
      scope <- askScopes
      span  <- askSpan
      bl <- fromValue c

      let
        fun x y = addProvenance (Provenance scope $ NIfAnnF span (pure c) x y)
        falseVal = (fun Nothing =<< pure) <$> fVal
        trueVal = (flip fun Nothing =<< pure) <$> tVal

      bool
        falseVal
        trueVal
        bl

  evalAssert c body =
    do
      span <- askSpan
      b <- fromValue c
      bool
        (nverr $ Assertion span c)
        (do
          scope <- askScopes
          join (addProvenance . Provenance scope . NAssertAnnF span (pure c) . pure) <$> body
        )
        b

  evalApp f x =
    do
      scope <- askScopes
      span  <- askSpan
      mkNVBinaryOpWithProvenance scope span NApp (pure f) Nothing <$> (callFunc f =<< defer x)

  evalAbs
    :: Params (m (NValue t f m))
    -> ( forall a
      . m (NValue t f m)
      -> ( AttrSet (m (NValue t f m))
        -> m (NValue t f m)
        -> m (a, NValue t f m)
        )
      -> m (a, NValue t f m)
      )
    -> m (NValue t f m)
  evalAbs p k =
    do
      scope <- askScopes
      span  <- askSpan
      pure $ mkNVClosureWithProvenance scope span (void p) (fmap snd . flip (k @()) (const (fmap (mempty ,))) . pure)

  evalError = throwError

infixl 1 `callFunc`
callFunc
  :: forall e t f m
   . MonadNix e t f m
  => NValue t f m
  -> NValue t f m
  -> m (NValue t f m)
callFunc fun arg =
  do
    frames <- askFrames
    when (length frames > 2000) $ throwError $ ErrorCall "Function call stack exhausted"

    fun' <- demand fun
    case fun' of
      NVClosure _params f -> f arg
      NVBuiltin name f    ->
        do
          span <- askSpan
          withFrame Info ((Calling @m @(NValue t f m)) name span) $ f arg -- Is this cool?
      (NVSet _ m) | Just f <- M.lookup "__functor" m ->
        (`callFunc` arg) =<< (`callFunc` fun') f
      _x -> throwError $ ErrorCall $ "Attempt to call non-function: " <> show _x

execUnaryOp
  :: forall e t f m
   . (Framed e m, MonadCited t f m, Show t)
  => Scopes m (NValue t f m)
  -> SrcSpan
  -> NUnaryOp
  -> NValue t f m
  -> m (NValue t f m)
execUnaryOp scope span op arg =
  case arg of
    NVConstant c ->
      case (op, c) of
        (NNeg, NInt   i) -> mkUnaryOp NInt negate i
        (NNeg, NFloat f) -> mkUnaryOp NFloat negate f
        (NNot, NBool  b) -> mkUnaryOp NBool not b
        _seq ->
          throwError $ ErrorCall $ "unsupported argument type for unary operator " <> show _seq
    _x ->
      throwError $ ErrorCall $ "argument to unary operator must evaluate to an atomic type: " <> show _x
 where
  mkUnaryOp :: (a -> NAtom) -> (a -> a) -> a -> m (NValue t f m)
  mkUnaryOp c b a = pure . mkNVUnaryOpWithProvenance scope span op (pure arg) . mkNVConstant $ c (b a)

execBinaryOp
  :: forall e t f m
   . (MonadNix e t f m, MonadEval (NValue t f m) m)
  => Scopes m (NValue t f m)
  -> SrcSpan
  -> NBinaryOp
  -> NValue t f m
  -> m (NValue t f m)
  -> m (NValue t f m)
execBinaryOp scope span op lval rarg =
  case op of
    NEq   -> helperEq id
    NNEq  -> helperEq not
    NOr   -> helperLogic flip True
    NAnd  -> helperLogic id   False
    NImpl -> helperLogic id   True
    _     ->
      do
        rval  <- rarg
        rval' <- demand rval
        lval' <- demand lval

        execBinaryOpForced scope span op lval' rval'

 where

  helperEq :: (Bool -> Bool) -> m (NValue t f m)
  helperEq flag =
    do
      rval <- rarg
      eq <- valueEqM lval rval
      boolOp rval $ flag eq

  helperLogic flp flag =
    flp bool
      (bypass flag)
      (do
          rval <- rarg
          x <- fromValue rval
          boolOp rval x
      )
      =<< fromValue lval

  boolOp rval = toBoolOp $ pure rval

  bypass      = toBoolOp Nothing

  toBoolOp :: Maybe (NValue t f m) -> Bool -> m (NValue t f m)
  toBoolOp r b =
    pure $ mkNVBinaryOpWithProvenance scope span op (pure lval) r $ mkNVConstant $ NBool b

execBinaryOpForced
  :: forall e t f m
   . (MonadNix e t f m, MonadEval (NValue t f m) m)
  => Scopes m (NValue t f m)
  -> SrcSpan
  -> NBinaryOp
  -> NValue t f m
  -> NValue t f m
  -> m (NValue t f m)

execBinaryOpForced scope span op lval rval =
  case op of
    NLt    -> mkCmpOp (<)
    NLte   -> mkCmpOp (<=)
    NGt    -> mkCmpOp (>)
    NGte   -> mkCmpOp (>=)
    NMinus -> mkBinNumOp (-)
    NMult  -> mkBinNumOp (*)
    NDiv   -> mkBinNumOp' div (/)
    NConcat ->
      case (lval, rval) of
        (NVList ls, NVList rs) -> pure $ mkListP $ ls <> rs
        _ -> unsupportedTypes

    NUpdate ->
      case (lval, rval) of
        (NVSet lp ls, NVSet rp rs) -> pure $ mkSetP (rp <> lp) (rs <> ls)
        (NVSet lp ls, NVConstant NNull) -> pure $ mkSetP lp ls
        (NVConstant NNull, NVSet rp rs) -> pure $ mkSetP rp rs
        _ -> unsupportedTypes

    NPlus ->
      case (lval, rval) of
        (NVConstant _, NVConstant _) -> mkBinNumOp (+)
        (NVStr ls, NVStr rs) -> pure $ mkStrP (ls <> rs)
        (NVStr ls, NVPath p) ->
          mkStrP . (ls <>) <$>
            coercePathToNixString CopyToStore p
        (NVPath ls, NVStr rs) ->
          maybe
            (throwError $ ErrorCall "A string that refers to a store path cannot be appended to a path.") -- data/nix/src/libexpr/eval.cc:1412
            (\ rs2 -> mkPathP <$> toAbsolutePath @t @f (ls <> coerce (toString rs2)))
            (getStringNoContext rs)
        (NVPath ls, NVPath rs) -> mkPathP <$> toAbsolutePath @t @f (ls <> rs)

        (ls@NVSet{}, NVStr rs) ->
          mkStrP . (<> rs) <$>
            coerceAnyToNixString callFunc DontCopyToStore ls
        (NVStr ls, rs@NVSet{}) ->
          mkStrP . (ls <>) <$>
            coerceAnyToNixString callFunc DontCopyToStore rs
        _ -> unsupportedTypes

    NApp  -> throwError $ ErrorCall "NApp should be handled by evalApp"
    _other   -> shouldBeAlreadyHandled

 where
  addProv :: NValue t f m -> NValue t f m
  addProv =
    mkNVBinaryOpWithProvenance scope span op (pure lval) (pure rval)

  mkBoolP :: Bool -> m (NValue t f m)
  mkBoolP = pure . addProv . mkNVConstant . NBool

  mkIntP :: Integer -> m (NValue t f m)
  mkIntP = pure . addProv . mkNVConstant . NInt

  mkFloatP :: Float -> m (NValue t f m)
  mkFloatP = pure . addProv . mkNVConstant . NFloat

  mkListP :: [NValue t f m] -> NValue t f m
  mkListP = addProv . mkNVList

  mkStrP :: NixString -> NValue t f m
  mkStrP = addProv . mkNVStr

  mkPathP :: Path -> NValue t f m
  mkPathP = addProv . mkNVPath

  mkSetP :: (PositionSet -> AttrSet (NValue t f m) -> NValue t f m)
  mkSetP x s = addProv $ mkNVSet x s

  mkCmpOp :: (forall a. Ord a => a -> a -> Bool) -> m (NValue t f m)
  mkCmpOp op = case (lval, rval) of
    (NVConstant l, NVConstant r) -> mkBoolP $ l `op` r
    (NVStr l, NVStr r) -> mkBoolP $ l `op` r
    _ -> unsupportedTypes

  mkBinNumOp :: (forall a. Num a => a -> a -> a) -> m (NValue t f m)
  mkBinNumOp op = mkBinNumOp' op op

  mkBinNumOp'
    :: (Integer -> Integer -> Integer)
    -> (Float -> Float -> Float)
    -> m (NValue t f m)
  mkBinNumOp' intOp floatOp =
    case (lval, rval) of
      (NVConstant l, NVConstant r) ->
        case (l, r) of
          (NInt   li, NInt   ri) -> mkIntP $ li `intOp` ri
          (NInt   li, NFloat rf) -> mkFloatP $ fromInteger li `floatOp` rf
          (NFloat lf, NInt   ri) -> mkFloatP $ lf `floatOp` fromInteger ri
          (NFloat lf, NFloat rf) -> mkFloatP $ lf `floatOp` rf
          _ -> unsupportedTypes
      _ -> unsupportedTypes

  unsupportedTypes = throwError $ ErrorCall $ "Unsupported argument types for binary operator " <> show op <> ": " <> show lval <> ", " <> show rval

  shouldBeAlreadyHandled = throwError $ ErrorCall $ "This cannot happen: operator " <> show op <> " should have been handled in execBinaryOp."


-- This function is here, rather than in 'Nix.String', because of the need to
-- use 'throwError'.
fromStringNoContext
  :: Framed e m
  => NixString
  -> m Text
fromStringNoContext ns =
  maybe
    (throwError $ ErrorCall $ "expected string with no context, but got " <> show ns)
    pure
    (getStringNoContext ns)

addTracing
  ::( MonadNix e t f m
    , Has e Options
    , Alternative n
    , MonadReader Int n
    , MonadFail n
    )
  => Alg NExprLocF (m a)
  -> Alg NExprLocF (n (m a))
addTracing k v = do
  depth <- ask
  guard $ depth < 2000
  local succ $ do
    v'@(AnnF span x) <- sequenceA v
    pure $ do
      opts <- askOptions
      let
        rendered =
          bool
            (prettyNix $ Fix $ Fix (NSym "?") <$ x)
            (pretty $ PS.ppShow $ void x)
            (getVerbosity opts >= Chatty)
        msg x = pretty ("eval: " <> replicate depth ' ') <> x
      loc <- renderLocation span $ msg rendered <> " ...\n"
      putStr $ show loc
      res <- k v'
      print $ msg rendered <> " ...done"
      pure res

evalWithTracingAndMetaInfo
  :: forall e t f m
  . MonadNix e t f m
  => NExprLoc
  -> ReaderT Int m (m (NValue t f m))
evalWithTracingAndMetaInfo =
  adi
    addMetaInfo
    (addTracing Eval.evalContent)
  where
  addMetaInfo :: (NExprLoc -> ReaderT r m a) -> NExprLoc -> ReaderT r m a
  addMetaInfo = (ReaderT .) . flip . (Eval.addMetaInfo .) . flip . (runReaderT .)

evalExprLoc :: forall e t f m . MonadNix e t f m => NExprLoc -> m (NValue t f m)
evalExprLoc expr =
  do
    opts <- askOptions
    let
      pTracedAdi =
        bool
          Eval.evalWithMetaInfo
          (join . (`runReaderT` (0 :: Int)) . evalWithTracingAndMetaInfo)
          (isTrace opts)
    pTracedAdi expr

exec :: (MonadNix e t f m, MonadInstantiate m) => [Text] -> m (NValue t f m)
exec args = either throwError evalExprLoc =<< exec' args

-- Please, delete `nix` from the name
nixInstantiateExpr
  :: (MonadNix e t f m, MonadInstantiate m) => Text -> m (NValue t f m)
nixInstantiateExpr s = either throwError evalExprLoc =<< instantiateExpr s