{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

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

-- | The nix expression type and supporting types.
module Nix.Expr.Types where

#ifdef MIN_VERSION_serialise
import           Codec.Serialise                ( Serialise )
import qualified Codec.Serialise               as Ser
#endif
import           Control.Applicative
import           Control.DeepSeq
import           Control.Monad
import           Data.Aeson
import           Data.Aeson.TH
import           Data.Binary                    ( Binary )
import qualified Data.Binary                   as Bin
import           Data.Data
import           Data.Eq.Deriving
import           Data.Fix
import           Data.Functor.Classes
import           Data.Hashable
#if MIN_VERSION_hashable(1, 2, 5)
import           Data.Hashable.Lifted
#endif
import           Data.List                      ( inits
                                                , tails
                                                )
import           Data.List.NonEmpty             ( NonEmpty(..) )
import qualified Data.List.NonEmpty            as NE
import           Data.Maybe                     ( fromMaybe )
import           Data.Ord.Deriving
import           Data.Text                      ( Text
                                                , pack
                                                , unpack
                                                )
import           Data.Traversable
import           GHC.Exts
import           GHC.Generics
import           Language.Haskell.TH.Syntax
import           Lens.Family2
import           Lens.Family2.TH
import           Nix.Atoms
import           Nix.Utils
import           Text.Megaparsec.Pos
import           Text.Read.Deriving
import           Text.Show.Deriving
#if MIN_VERSION_base(4, 10, 0)
import           Type.Reflection                ( eqTypeRep )
import qualified Type.Reflection               as Reflection
#endif

type VarName = Text

hashAt :: VarName -> Lens' (AttrSet v) (Maybe v)
hashAt = flip alterF

-- unfortunate orphans
#if MIN_VERSION_hashable(1, 2, 5)
instance Hashable1 NonEmpty
#endif

#if !MIN_VERSION_base(4, 10, 0)
instance Eq1 NonEmpty where
  liftEq eq (a NE.:| as) (b NE.:| bs) = eq a b && liftEq eq as bs
instance Show1 NonEmpty where
  liftShowsPrec shwP shwL p (a NE.:| as) = showParen (p > 5) $
    shwP 6 a . showString " :| " . shwL as
#endif

#if !MIN_VERSION_binary(0, 8, 4)
instance Binary a => Binary (NE.NonEmpty a) where
  get = fmap NE.fromList Bin.get
  put = Bin.put . NE.toList
#endif

-- | The main nix expression type. This is polymorphic so that it can be made
-- a functor, which allows us to traverse expressions and map functions over
-- them. The actual 'NExpr' type is a fixed point of this functor, defined
-- below.
data NExprF r
  = NConstant !NAtom
  -- ^ Constants: ints, bools, URIs, and null.
  | NStr !(NString r)
  -- ^ A string, with interpolated expressions.
  | NSym !VarName
  -- ^ A variable. For example, in the expression @f a@, @f@ is represented
  -- as @NSym "f"@ and @a@ as @NSym "a"@.
  | NList ![r]
  -- ^ A list literal.
  | NSet ![Binding r]
  -- ^ An attribute set literal, not recursive.
  | NRecSet ![Binding r]
  -- ^ An attribute set literal, recursive.
  | NLiteralPath !FilePath
  -- ^ A path expression, which is evaluated to a store path. The path here
  -- can be relative, in which case it's evaluated relative to the file in
  -- which it appears.
  | NEnvPath !FilePath
  -- ^ A path which refers to something in the Nix search path (the NIX_PATH
  -- environment variable. For example, @<nixpkgs/pkgs>@.
  | NUnary !NUnaryOp !r
  -- ^ Application of a unary operator to an expression.
  | NBinary !NBinaryOp !r !r
  -- ^ Application of a binary operator to two expressions.
  | NSelect !r !(NAttrPath r) !(Maybe r)
  -- ^ Dot-reference into an attribute set, optionally providing an
  -- alternative if the key doesn't exist.
  | NHasAttr !r !(NAttrPath r)
  -- ^ Ask if a set contains a given attribute path.
  | NAbs !(Params r) !r
  -- ^ A function literal (lambda abstraction).
  | NLet ![Binding r] !r
  -- ^ Evaluate the second argument after introducing the bindings.
  | NIf !r !r !r
  -- ^ If-then-else statement.
  | NWith !r !r
  -- ^ Evaluate an attribute set, bring its bindings into scope, and
  -- evaluate the second argument.
  | NAssert !r !r
  -- ^ Assert that the first returns true before evaluating the second.
  | NSynHole !VarName
  -- ^ Syntactic hole, e.g. @^foo@ , @^hole_name@
  deriving (Ord, Eq, Generic, Generic1, Typeable, Data, Functor,
            Foldable, Traversable, Show, NFData, Hashable)

#if MIN_VERSION_hashable(1, 2, 5)
instance Hashable1 NExprF
#endif

#if MIN_VERSION_deepseq(1, 4, 3)
instance NFData1 NExprF
#endif

#ifdef MIN_VERSION_serialise
instance Serialise r => Serialise (NExprF r)
#endif

-- | We make an `IsString` for expressions, where the string is interpreted
-- as an identifier. This is the most common use-case...
instance IsString NExpr where
  fromString = Fix . NSym . fromString

#if MIN_VERSION_base(4, 10, 0)
instance Lift (Fix NExprF) where
  lift = dataToExpQ $ \b ->
    case Reflection.typeOf b `eqTypeRep` Reflection.typeRep @Text of
      Just HRefl -> Just [| pack $(liftString $ unpack b) |]
      Nothing    -> Nothing
#else
instance Lift (Fix NExprF) where
    lift = dataToExpQ $ \b -> case cast b of
        Just t -> Just [| pack $(liftString $ unpack t) |]
        Nothing -> Nothing
#endif

-- | The monomorphic expression type is a fixed point of the polymorphic one.
type NExpr = Fix NExprF

#ifdef MIN_VERSION_serialise
instance Serialise NExpr
#endif

-- | A single line of the bindings section of a let expression or of a set.
data Binding r
  = NamedVar !(NAttrPath r) !r !SourcePos
  -- ^ An explicit naming, such as @x = y@ or @x.y = z@.
  | Inherit !(Maybe r) ![NKeyName r] !SourcePos
  -- ^ Using a name already in scope, such as @inherit x;@ which is shorthand
  --   for @x = x;@ or @inherit (x) y;@ which means @y = x.y;@. The
  --   unsafeGetAttrPos for every name so inherited is the position of the
  --   first name, whether that be the first argument to this constructor, or
  --   the first member of the list in the second argument.
  deriving (Generic, Generic1, Typeable, Data, Ord, Eq, Functor,
            Foldable, Traversable, Show, NFData, Hashable)

#if MIN_VERSION_hashable(1, 2, 5)
instance Hashable1 Binding
#endif

#if MIN_VERSION_deepseq(1, 4, 3)
instance NFData1 Binding
#endif

#ifdef MIN_VERSION_serialise
instance Serialise r => Serialise (Binding r)
#endif

-- | @Params@ represents all the ways the formal parameters to a
-- function can be represented.
data Params r
  = Param !VarName
  -- ^ For functions with a single named argument, such as @x: x + 1@.
  | ParamSet !(ParamSet r) !Bool !(Maybe VarName)
  -- ^ Explicit parameters (argument must be a set). Might specify a name to
  -- bind to the set in the function body. The bool indicates whether it is
  -- variadic or not.
  deriving (Ord, Eq, Generic, Generic1, Typeable, Data, Functor, Show,
            Foldable, Traversable, NFData, Hashable)

#if MIN_VERSION_hashable(1, 2, 5)
instance Hashable1 Params
#endif

#if MIN_VERSION_deepseq(1, 4, 3)
instance NFData1 Params
#endif

#ifdef MIN_VERSION_serialise
instance Serialise r => Serialise (Params r)
#endif

-- This uses an association list because nix XML serialization preserves the
-- order of the param set.
type ParamSet r = [(VarName, Maybe r)]

instance IsString (Params r) where
  fromString = Param . fromString

-- | 'Antiquoted' represents an expression that is either
-- antiquoted (surrounded by ${...}) or plain (not antiquoted).
data Antiquoted (v :: *) (r :: *) = Plain !v | EscapedNewline | Antiquoted !r
  deriving (Ord, Eq, Generic, Generic1, Typeable, Data, Functor, Foldable,
            Traversable, Show, Read, NFData, Hashable)

#if MIN_VERSION_hashable(1, 2, 5)
instance Hashable v => Hashable1 (Antiquoted v)

instance Hashable2 Antiquoted where
  liftHashWithSalt2 ha _ salt (Plain a) = ha (salt `hashWithSalt` (0 :: Int)) a
  liftHashWithSalt2 _ _ salt EscapedNewline = salt `hashWithSalt` (1 :: Int)
  liftHashWithSalt2 _ hb salt (Antiquoted b) =
    hb (salt `hashWithSalt` (2 :: Int)) b
#endif

#if MIN_VERSION_deepseq(1, 4, 3)
instance NFData v => NFData1 (Antiquoted v)
#endif

#ifdef MIN_VERSION_serialise
instance (Serialise v, Serialise r) => Serialise (Antiquoted v r)
#endif

-- | An 'NString' is a list of things that are either a plain string
-- or an antiquoted expression. After the antiquotes have been evaluated,
-- the final string is constructed by concating all the parts.
data NString r
  = DoubleQuoted ![Antiquoted Text r]
  -- ^ Strings wrapped with double-quotes (") can contain literal newline
  -- characters, but the newlines are preserved and no indentation is stripped.
  | Indented !Int ![Antiquoted Text r]
  -- ^ Strings wrapped with two single quotes ('') can contain newlines, and
  --   their indentation will be stripped, but the amount stripped is
  --   remembered.
  deriving (Eq, Ord, Generic, Generic1, Typeable, Data, Functor, Foldable,
            Traversable, Show, Read, NFData, Hashable)

#if MIN_VERSION_hashable(1, 2, 5)
instance Hashable1 NString
#endif

#if MIN_VERSION_deepseq(1, 4, 3)
instance NFData1 NString
#endif

#ifdef MIN_VERSION_serialise
instance Serialise r => Serialise (NString r)
#endif

-- | For the the 'IsString' instance, we use a plain doublequoted string.
instance IsString (NString r) where
  fromString ""     = DoubleQuoted []
  fromString string = DoubleQuoted [Plain $ pack string]

-- | A 'KeyName' is something that can appear on the left side of an
-- equals sign. For example, @a@ is a 'KeyName' in @{ a = 3; }@, @let a = 3;
-- in ...@, @{}.a@ or @{} ? a@.
--
-- Nix supports both static keynames (just an identifier) and dynamic
-- identifiers. Dynamic identifiers can be either a string (e.g.:
-- @{ "a" = 3; }@) or an antiquotation (e.g.: @let a = "example";
-- in { ${a} = 3; }.example@).
--
-- Note: There are some places where a dynamic keyname is not allowed.
-- In particular, those include:
--
--   * The RHS of a @binding@ inside @let@: @let ${"a"} = 3; in ...@
--     produces a syntax error.
--   * The attribute names of an 'inherit': @inherit ${"a"};@ is forbidden.
--
-- Note: In Nix, a simple string without antiquotes such as @"foo"@ is
-- allowed even if the context requires a static keyname, but the
-- parser still considers it a 'DynamicKey' for simplicity.
data NKeyName r
  = DynamicKey !(Antiquoted (NString r) r)
  | StaticKey !VarName
  deriving (Eq, Ord, Generic, Typeable, Data, Show, Read, NFData, Hashable)

#ifdef MIN_VERSION_serialise
instance Serialise r => Serialise (NKeyName r)

instance Serialise Pos where
  encode x = Ser.encode (unPos x)
  decode = mkPos <$> Ser.decode

instance Serialise SourcePos where
  encode (SourcePos f l c) = Ser.encode f <> Ser.encode l <> Ser.encode c
  decode = SourcePos <$> Ser.decode <*> Ser.decode <*> Ser.decode
#endif

instance Hashable Pos where
  hashWithSalt salt x = hashWithSalt salt (unPos x)

instance Hashable SourcePos where
  hashWithSalt salt (SourcePos f l c) =
    salt `hashWithSalt` f `hashWithSalt` l `hashWithSalt` c

instance Generic1 NKeyName where
  type Rep1 NKeyName = NKeyName
  from1 = id
  to1   = id

#if MIN_VERSION_deepseq(1, 4, 3)
instance NFData1 NKeyName where
  liftRnf _ (StaticKey  !_            ) = ()
  liftRnf _ (DynamicKey (Plain !_)    ) = ()
  liftRnf _ (DynamicKey EscapedNewline) = ()
  liftRnf k (DynamicKey (Antiquoted r)) = k r
#endif

-- | Most key names are just static text, so this instance is convenient.
instance IsString (NKeyName r) where
  fromString = StaticKey . fromString

instance Eq1 NKeyName where
  liftEq eq (DynamicKey a) (DynamicKey b) = liftEq2 (liftEq eq) eq a b
  liftEq _  (StaticKey  a) (StaticKey  b) = a == b
  liftEq _  _              _              = False

#if MIN_VERSION_hashable(1, 2, 5)
instance Hashable1 NKeyName where
  liftHashWithSalt h salt (DynamicKey a) =
    liftHashWithSalt2 (liftHashWithSalt h) h (salt `hashWithSalt` (0 :: Int)) a
  liftHashWithSalt _ salt (StaticKey n) =
    salt `hashWithSalt` (1 :: Int) `hashWithSalt` n
#endif

-- Deriving this instance automatically is not possible because @r@
-- occurs not only as last argument in @Antiquoted (NString r) r@
instance Show1 NKeyName where
  liftShowsPrec sp sl p = \case
    DynamicKey a -> showsUnaryWith
      (liftShowsPrec2 (liftShowsPrec sp sl) (liftShowList sp sl) sp sl)
      "DynamicKey"
      p
      a
    StaticKey t -> showsUnaryWith showsPrec "StaticKey" p t

-- Deriving this instance automatically is not possible because @r@
-- occurs not only as last argument in @Antiquoted (NString r) r@
instance Functor NKeyName where
  fmap = fmapDefault

-- Deriving this instance automatically is not possible because @r@
-- occurs not only as last argument in @Antiquoted (NString r) r@
instance Foldable NKeyName where
  foldMap = foldMapDefault

-- Deriving this instance automatically is not possible because @r@
-- occurs not only as last argument in @Antiquoted (NString r) r@
instance Traversable NKeyName where
  traverse f = \case
    DynamicKey (Plain      str) -> DynamicKey . Plain <$> traverse f str
    DynamicKey (Antiquoted e  ) -> DynamicKey . Antiquoted <$> f e
    DynamicKey EscapedNewline   -> pure $ DynamicKey EscapedNewline
    StaticKey  key              -> pure (StaticKey key)

-- | A selector (for example in a @let@ or an attribute set) is made up
-- of strung-together key names.
type NAttrPath r = NonEmpty (NKeyName r)

-- | There are two unary operations: logical not and integer negation.
data NUnaryOp = NNeg | NNot
  deriving (Eq, Ord, Enum, Bounded, Generic, Typeable, Data, Show, Read,
            NFData, Hashable)

#ifdef MIN_VERSION_serialise
instance Serialise NUnaryOp
#endif

-- | Binary operators expressible in the nix language.
data NBinaryOp
  = NEq      -- ^ Equality (==)
  | NNEq     -- ^ Inequality (!=)
  | NLt      -- ^ Less than (<)
  | NLte     -- ^ Less than or equal (<=)
  | NGt      -- ^ Greater than (>)
  | NGte     -- ^ Greater than or equal (>=)
  | NAnd     -- ^ Logical and (&&)
  | NOr      -- ^ Logical or (||)
  | NImpl    -- ^ Logical implication (->)
  | NUpdate  -- ^ Joining two attribute sets (//)
  | NPlus    -- ^ Addition (+)
  | NMinus   -- ^ Subtraction (-)
  | NMult    -- ^ Multiplication (*)
  | NDiv     -- ^ Division (/)
  | NConcat  -- ^ List concatenation (++)
  | NApp     -- ^ Apply a function to an argument.
  deriving (Eq, Ord, Enum, Bounded, Generic, Typeable, Data, Show, Read,
            NFData, Hashable)

#ifdef MIN_VERSION_serialise
instance Serialise NBinaryOp
#endif

-- | Get the name out of the parameter (there might be none).
paramName :: Params r -> Maybe VarName
paramName (Param n       ) = Just n
paramName (ParamSet _ _ n) = n

#if !MIN_VERSION_deepseq(1, 4, 3)
instance NFData NExpr
#endif

$(deriveEq1 ''NExprF)
$(deriveEq1 ''NString)
$(deriveEq1 ''Binding)
$(deriveEq1 ''Params)
$(deriveEq1 ''Antiquoted)
$(deriveEq2 ''Antiquoted)

$(deriveOrd1 ''NString)
$(deriveOrd1 ''Params)
$(deriveOrd1 ''Antiquoted)
$(deriveOrd2 ''Antiquoted)

$(deriveRead1 ''NString)
$(deriveRead1 ''Params)
$(deriveRead1 ''Antiquoted)
$(deriveRead2 ''Antiquoted)

$(deriveShow1 ''NExprF)
$(deriveShow1 ''NString)
$(deriveShow1 ''Params)
$(deriveShow1 ''Binding)
$(deriveShow1 ''Antiquoted)
$(deriveShow2 ''Antiquoted)

-- $(deriveJSON1 defaultOptions ''NExprF)
$(deriveJSON1 defaultOptions ''NString)
$(deriveJSON1 defaultOptions ''Params)
-- $(deriveJSON1 defaultOptions ''Binding)
$(deriveJSON1 defaultOptions ''Antiquoted)
$(deriveJSON2 defaultOptions ''Antiquoted)

instance (Binary v, Binary a) => Binary (Antiquoted v a)
instance Binary a => Binary (NString a)
instance Binary a => Binary (Binding a)
instance Binary Pos where
  put x = Bin.put (unPos x)
  get = mkPos <$> Bin.get
instance Binary SourcePos
instance Binary a => Binary (NKeyName a)
instance Binary a => Binary (Params a)
instance Binary NAtom
instance Binary NUnaryOp
instance Binary NBinaryOp
instance Binary a => Binary (NExprF a)

instance (ToJSON v, ToJSON a) => ToJSON (Antiquoted v a)
instance ToJSON a => ToJSON (NString a)
instance ToJSON a => ToJSON (Binding a)
instance ToJSON Pos where
  toJSON x = toJSON (unPos x)
instance ToJSON SourcePos
instance ToJSON a => ToJSON (NKeyName a)
instance ToJSON a => ToJSON (Params a)
instance ToJSON NAtom
instance ToJSON NUnaryOp
instance ToJSON NBinaryOp
instance ToJSON a => ToJSON (NExprF a)
instance ToJSON NExpr

instance (FromJSON v, FromJSON a) => FromJSON (Antiquoted v a)
instance FromJSON a => FromJSON (NString a)
instance FromJSON a => FromJSON (Binding a)
instance FromJSON Pos where
  parseJSON = fmap mkPos . parseJSON
instance FromJSON SourcePos
instance FromJSON a => FromJSON (NKeyName a)
instance FromJSON a => FromJSON (Params a)
instance FromJSON NAtom
instance FromJSON NUnaryOp
instance FromJSON NBinaryOp
instance FromJSON a => FromJSON (NExprF a)
instance FromJSON NExpr

$(makeTraversals ''NExprF)
$(makeTraversals ''Binding)
$(makeTraversals ''Params)
$(makeTraversals ''Antiquoted)
$(makeTraversals ''NString)
$(makeTraversals ''NKeyName)
$(makeTraversals ''NUnaryOp)
$(makeTraversals ''NBinaryOp)

-- $(makeLenses ''Fix)

class NExprAnn ann g | g -> ann where
    fromNExpr :: g r -> (NExprF r, ann)
    toNExpr :: (NExprF r, ann) -> g r

ekey
  :: NExprAnn ann g
  => NonEmpty Text
  -> SourcePos
  -> Lens' (Fix g) (Maybe (Fix g))
ekey keys pos f e@(Fix x) | (NSet xs, ann) <- fromNExpr x = case go xs of
  ((v, []      ) : _) -> fromMaybe e <$> f (Just v)
  ((v, r : rest) : _) -> ekey (r :| rest) pos f v

  _                   -> f Nothing <&> \case
    Nothing -> e
    Just v ->
      let entry = NamedVar (NE.map StaticKey keys) v pos
      in  Fix (toNExpr (NSet (entry : xs), ann))
 where
  go xs = do
    let keys' = NE.toList keys
    (ks, rest) <- zip (inits keys') (tails keys')
    case ks of
      []     -> empty
      j : js -> do
        NamedVar ns v _p <- xs
        guard $ (j : js) == (NE.toList ns ^.. traverse . _StaticKey)
        return (v, rest)

ekey _ _ f e = fromMaybe e <$> f Nothing

stripPositionInfo :: NExpr -> NExpr
stripPositionInfo = transport phi
 where
  phi (NSet    binds  ) = NSet (map go binds)
  phi (NRecSet binds  ) = NRecSet (map go binds)
  phi (NLet binds body) = NLet (map go binds) body
  phi x                 = x

  go (NamedVar path r     _pos) = NamedVar path r nullPos
  go (Inherit  ms   names _pos) = Inherit ms names nullPos

nullPos :: SourcePos
nullPos = SourcePos "<string>" (mkPos 1) (mkPos 1)