{-# language ConstraintKinds #-}
{-# language CPP #-}
{-# language DeriveAnyClass #-}
{-# language FunctionalDependencies #-}
{-# language RankNTypes #-}
{-# language TemplateHaskell #-}
{-# language TypeFamilies #-}

{-# options_ghc -Wno-orphans #-}
{-# options_ghc -Wno-name-shadowing #-}
{-# options_ghc -Wno-missing-signatures #-}

-- | The Nix expression type and supporting types.
--
-- [Brief introduction of the Nix expression language.](https://nixos.org/nix/manual/#ch-expression-language)
--
-- This module is a beginning of a deep embedding (term) of a Nix language into Haskell.
-- [Brief on shallow & deep embedding.](https://web.archive.org/web/20201112031804/https://alessandrovermeulen.me/2013/07/13/the-difference-between-shallow-and-deep-embedding/)
--
-- (additiona info for dev): Big use of TemplateHaskell in the module requires proper (top-down) organization of declarations.
module Nix.Expr.Types
  ( module Nix.Expr.Types
  , SourcePos(..)
  , unPos
  , mkPos
  )
where

import           Nix.Prelude
import qualified Codec.Serialise               as Serialise
import           Codec.Serialise                ( Serialise )
import           Control.DeepSeq                ( NFData1(..) )
import           Data.Aeson
import qualified Data.Binary                   as Binary
import           Data.Binary                    ( Binary )
import           Data.Data
import           Data.Fix                       ( Fix(..) )
import           Data.Functor.Classes
import           Data.Hashable.Lifted
import qualified Data.HashMap.Lazy             as MapL
import qualified Data.Set                      as Set
import qualified Data.List.NonEmpty            as NE
import qualified Text.Show
import           Data.Traversable               ( fmapDefault, foldMapDefault )
import           GHC.Generics
import qualified Language.Haskell.TH.Syntax    as TH
import           Lens.Family2
import           Lens.Family2.TH
import           Text.Megaparsec.Pos            ( Pos
                                                , mkPos
                                                , unPos
                                                , SourcePos(SourcePos)
                                                )
import           Text.Show.Deriving             ( deriveShow1, deriveShow2 )
import           Text.Read.Deriving             ( deriveRead1, deriveRead2 )
import           Data.Eq.Deriving               ( deriveEq1  , deriveEq2   )
import           Data.Ord.Deriving              ( deriveOrd1 , deriveOrd2  )
import           Data.Aeson.TH                  ( deriveJSON2 )
import qualified Type.Reflection               as Reflection
import           Nix.Atoms
#if !MIN_VERSION_text(1,2,4)
-- NOTE: Remove package @th-lift-instances@ removing this
import           Instances.TH.Lift              ()  -- importing Lift Text for GHC 8.6
#endif


-- * utils

newtype NPos = NPos Pos
 deriving
   ( Eq, Ord
   , Read, Show
   , Data, NFData
   , Generic
   )

instance Semigroup NPos where
  (NPos x) <> (NPos y) = NPos (x <> y)

-- | Represents source positions.
-- Source line & column positions change intensively during parsing,
-- so they are declared strict to avoid memory leaks.
--
-- The data type is a reimplementation of 'Text.Megaparsec.Pos' 'SourcePos'.
data NSourcePos =
  NSourcePos
  { -- | Name of source file
    getSourceName :: Path,
    -- | Line number
    getSourceLine :: !NPos,
    -- | Column number
    getSourceColumn :: !NPos
  }
 deriving
   ( Eq, Ord
   , Read, Show
   , Data, NFData
   , Generic
   )

-- | Helper for 'SourcePos' -> 'NSourcePos' coersion.
toNSourcePos :: SourcePos -> NSourcePos
toNSourcePos (SourcePos f l c) =
  NSourcePos (coerce f) (coerce l) (coerce c)

-- | Helper for 'NSourcePos' -> 'SourcePos' coersion.
toSourcePos :: NSourcePos -> SourcePos
toSourcePos (NSourcePos f l c) =
  SourcePos (coerce f) (coerce l) (coerce c)

--  2021-07-16: NOTE: Should replace @ParamSet@ List
-- | > Hashmap VarName -- type synonym
type AttrSet = HashMap VarName

-- | Holds file positionng information for abstrations.
-- A type synonym for @HashMap VarName NSourcePos@.
type PositionSet = AttrSet NSourcePos

-- ** Additional N{,Source}Pos instances

-- Placed here because TH inference depends on declaration sequence.

instance Serialise NPos where
  encode = Serialise.encode . unPos . coerce
  decode = coerce . mkPos <$> Serialise.decode

instance Serialise NSourcePos where
  encode (NSourcePos f l c) =
    coerce $
    Serialise.encode f <>
    Serialise.encode l <>
    Serialise.encode c
  decode =
    liftA3 NSourcePos
      Serialise.decode
      Serialise.decode
      Serialise.decode

instance Hashable NPos where
  hashWithSalt salt = hashWithSalt salt . unPos . coerce

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

instance Binary NPos where
  put = (Binary.put @Int) . unPos . coerce
  get = coerce . mkPos <$> Binary.get
instance Binary NSourcePos

instance ToJSON NPos where
  toJSON = toJSON . unPos . coerce
instance ToJSON NSourcePos

instance FromJSON NPos where
  parseJSON = coerce . fmap mkPos . parseJSON
instance FromJSON NSourcePos

-- * Components of Nix expressions

-- NExpr is a composition of
--   * direct reuse of the Haskell types (list, Path, Text)
--   * NAtom
--   * Types in this section
--   * Fixpoint nature

-- ** newtype VarName

newtype VarName = VarName Text
  deriving
    ( Eq, Ord, Generic
    , Typeable, Data, NFData, Serialise, Binary, ToJSON, FromJSON
    , Show, Read, Hashable
    )

instance IsString VarName where
  fromString = coerce . fromString @Text

instance ToString VarName where
  toString = toString @Text . coerce

-- ** data Params

-- *** utils

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

data Variadic = Closed | Variadic
  deriving
    ( Eq, Ord, Generic
    , Typeable, Data, NFData, Serialise, Binary, ToJSON, FromJSON
    , Show, Read, Hashable
    )

instance Semigroup Variadic where
  (<>) Closed Closed = Closed
  (<>) _      _      = Variadic

instance Monoid Variadic where
  mempty = Closed

-- *** data Params

-- | @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@.
  --
  -- > Param "x"                                  ~  x
  | ParamSet !(Maybe VarName) !Variadic !(ParamSet r)
  -- ^ 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.
  --
  -- > ParamSet  Nothing   False [("x",Nothing)]  ~  { x }
  -- > ParamSet (pure "s") True  [("x", pure y)]  ~  s@{ x ? y, ... }
  deriving
    ( Eq, Ord, Generic, Generic1
    , Typeable, Data, NFData, NFData1, Serialise, Binary, ToJSON, ToJSON1, FromJSON, FromJSON1
    , Functor, Foldable, Traversable
    , Show, Read, Hashable
    )

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

$(deriveShow1 ''Params)
$(deriveRead1 ''Params)
$(deriveEq1   ''Params)
$(deriveOrd1  ''Params)

deriving instance Hashable1 Params

-- *** lens traversals

$(makeTraversals ''Params)


-- ** data Antiquoted

-- | 'Antiquoted' represents an expression that is either
-- antiquoted (surrounded by ${...}) or plain (not antiquoted).
data Antiquoted (v :: Type) (r :: Type)
  = Plain !v
  | EscapedNewline
  -- ^ 'EscapedNewline' corresponds to the special newline form
  --
  -- > ''\n
  --
  -- in an indented string. It is equivalent to a single newline character:
  --
  -- > ''''\n''  ≡  "\n"
  | Antiquoted !r
  deriving
    ( Eq, Ord, Generic, Generic1
    , Typeable, Data, NFData, NFData1, Serialise, Binary
    , ToJSON, ToJSON1, FromJSON, FromJSON1
    , Functor, Foldable, Traversable
    , Show, Read, Hashable
    )

$(deriveShow1 ''Antiquoted)
$(deriveShow2 ''Antiquoted)
$(deriveRead1 ''Antiquoted)
$(deriveRead2 ''Antiquoted)
$(deriveEq1   ''Antiquoted)
$(deriveEq2   ''Antiquoted)
$(deriveOrd1  ''Antiquoted)
$(deriveOrd2  ''Antiquoted)
$(deriveJSON2 defaultOptions ''Antiquoted)

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

deriving instance (Hashable v) => Hashable1 (Antiquoted (v :: Type))

-- *** lens traversals

$(makeTraversals ''Antiquoted)


-- ** data NString

-- | 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 concatenating 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.
  --
  -- > DoubleQuoted [Plain "x",Antiquoted y]   ~  "x${y}"
  | 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.
  --
  -- > Indented 1 [Plain "x"]                  ~  '' x''
  -- >
  -- > Indented 0 [EscapedNewline]             ~  ''''\n''
  -- >
  -- > Indented 0 [Plain "x\n ",Antiquoted y]  ~  ''
  -- >                                            x
  -- >                                             ${y}''
  deriving
    ( Eq, Ord, Generic, Generic1
    , Typeable, Data, NFData, NFData1, Serialise, Binary, ToJSON, ToJSON1, FromJSON, FromJSON1
    , Functor, Foldable, Traversable
    , Show, Read, Hashable
    )

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

$(deriveShow1 ''NString)
$(deriveRead1 ''NString)
$(deriveEq1   ''NString)
$(deriveOrd1  ''NString)

deriving instance Hashable1 NString

-- *** lens traversals

$(makeTraversals ''NString)


-- ** data NKeyName

-- | 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 fail.
--   * 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)
  -- ^
  -- > DynamicKey (Plain (DoubleQuoted [Plain "x"]))     ~  "x"
  -- > DynamicKey (Antiquoted x)                         ~  ${x}
  -- > DynamicKey (Plain (DoubleQuoted [Antiquoted x]))  ~  "${x}"
  | StaticKey !VarName
  -- ^
  -- > StaticKey "x"                                     ~  x
  deriving
    ( Eq, Ord, Generic
    , Typeable, Data, NFData, Serialise, Binary, ToJSON, FromJSON
    , Show, Read, Hashable
    )

instance NFData1 NKeyName where
  liftRnf _ (StaticKey  !_            ) = mempty
  liftRnf _ (DynamicKey (Plain !_)    ) = mempty
  liftRnf _ (DynamicKey EscapedNewline) = mempty
  liftRnf k (DynamicKey (Antiquoted r)) = k r

-- | 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

-- | @since 0.10.1
instance Ord1 NKeyName where
  liftCompare cmp (DynamicKey a) (DynamicKey b) = liftCompare2 (liftCompare cmp) cmp a b
  liftCompare _   (DynamicKey _) (StaticKey  _) = LT
  liftCompare _   (StaticKey  _) (DynamicKey _) = GT
  liftCompare _   (StaticKey  a) (StaticKey  b) = compare a b

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

-- 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 Text.Show.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

-- *** lens traversals

$(makeTraversals ''NKeyName)


-- ** type NAttrPath

-- | A selector (for example in a @let@ or an attribute set) is made up
-- of strung-together key names.
--
-- > StaticKey "x" :| [DynamicKey (Antiquoted y)]  ~  x.${y}
type NAttrPath r = NonEmpty (NKeyName r)


-- ** data Binding

#if !MIN_VERSION_hashable(1,3,1)
-- Required by Hashable Binding deriving. There was none of this Hashable instance before mentioned version, remove this in year >2022
instance Hashable1 NonEmpty
#endif

-- | A single line of the bindings section of a let expression or of a set.
data Binding r
  = NamedVar !(NAttrPath r) !r !NSourcePos
  -- ^ An explicit naming.
  --
  -- > NamedVar (StaticKey "x" :| [StaticKey "y"]) z NSourcePos{}  ~  x.y = z;
  | Inherit !(Maybe r) ![VarName] !NSourcePos
  -- ^ Inheriting an attribute (binding) into the attribute set from the other scope (attribute set). No denoted scope means to inherit from the closest outside scope.
  --
  -- +----------------------------------------------------------------+--------------------+-----------------------+
  -- | Hask                                                           | Nix                | pseudocode            |
  -- +================================================================+====================+=======================+
  -- | @Inherit Nothing  [StaticKey "a"] NSourcePos{}@                | @inherit a;@       | @a = outside.a;@      |
  -- +----------------------------------------------------------------+--------------------+-----------------------+
  -- | @Inherit (pure x) [StaticKey "a"] NSourcePos{}@                | @inherit (x) a;@   | @a = x.a;@            |
  -- +----------------------------------------------------------------+--------------------+-----------------------+
  -- | @Inherit (pure x) [StaticKey "a", StaticKey "b"] NSourcePos{}@ | @inherit (x) a b;@ | @a = x.a;@            |
  -- |                                                                |                    | @b = x.b;@            |
  -- +----------------------------------------------------------------+--------------------+-----------------------+
  --
  -- (2021-07-07 use details):
  -- Inherits the position of the first name through @unsafeGetAttrPos@. The position of the scope inherited from else - the position of the first member of the binds list.
  deriving
    ( Eq, Ord, Generic, Generic1
    , Typeable, Data, NFData, NFData1, Serialise, Binary, ToJSON, FromJSON
    , Functor, Foldable, Traversable
    , Show, Hashable
    )

$(deriveShow1 ''Binding)
$(deriveEq1   ''Binding)
$(deriveOrd1  ''Binding)
--x $(deriveJSON1 defaultOptions ''Binding)

deriving instance Hashable1 Binding

-- *** lens traversals

$(makeTraversals ''Binding)


-- ** data Recursivity

-- | Distinguishes between recursive and non-recursive. Mainly for attribute
-- sets.
data Recursivity
  = NonRecursive  -- ^ >     { ... }
  | Recursive     -- ^ > rec { ... }
  deriving
    ( Eq, Ord, Enum, Bounded, Generic
    , Typeable, Data, NFData, Serialise, Binary, ToJSON, FromJSON
    , Show, Read, Hashable
    )

instance Semigroup Recursivity where
  (<>) NonRecursive NonRecursive = NonRecursive
  (<>) _ _ = Recursive

instance Monoid Recursivity where
  mempty = NonRecursive

-- ** data NUnaryOp

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

-- *** lens traversals

$(makeTraversals ''NUnaryOp)

-- ** data NBinaryOp

-- | 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  -- ^ Get the left attr set, extend it with the right one & override equal keys (@//@)
  | NPlus    -- ^ Addition (@+@)
  | NMinus   -- ^ Subtraction (@-@)
  | NMult    -- ^ Multiplication (@*@)
  | NDiv     -- ^ Division (@/@)
  | NConcat  -- ^ List concatenation (@++@)
  deriving
    ( Eq, Ord, Enum, Bounded, Generic
    , Typeable, Data, NFData, Serialise, Binary, ToJSON, FromJSON
    , Show, Read, Hashable
    )

-- *** lens traversals

$(makeTraversals ''NBinaryOp)


-- * data NExprF - Nix expressions, base functor

-- | The main Nix expression type. As it is polimorphic, has a functor,
-- which allows 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, floats, 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"@.
  --
  -- > NSym "x"                                    ~  x
  | NList ![r]
  -- ^ A list literal.
  --
  -- > NList [x,y]                                 ~  [ x y ]
  | NSet !Recursivity ![Binding r]
  -- ^ An attribute set literal
  --
  -- > NSet Recursive    [NamedVar x y _]         ~  rec { x = y; }
  -- > NSet NonRecursive [Inherit Nothing [x] _]  ~  { inherit x; }
  | NLiteralPath !Path
  -- ^ 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.
  --
  -- > NLiteralPath "/x"                           ~  /x
  -- > NLiteralPath "x/y"                          ~  x/y
  | NEnvPath !Path
  -- ^ A path which refers to something in the Nix search path (the NIX_PATH
  -- environment variable. For example, @<nixpkgs/pkgs>@.
  --
  -- > NEnvPath "x"                                ~  <x>
  | NApp !r !r
  -- ^ Functional application (aka F.A., apply a function to an argument).
  --
  -- > NApp f x  ~  f x
  | NUnary !NUnaryOp !r
  -- ^ Application of a unary operator to an expression.
  --
  -- > NUnary NNeg x                               ~  - x
  -- > NUnary NNot x                               ~  ! x
  | NBinary !NBinaryOp !r !r
  -- ^ Application of a binary operator to two expressions.
  --
  -- > NBinary NPlus x y                           ~  x + y
  -- > NBinary NApp  f x                           ~  f x
  | NSelect !(Maybe r) !r !(NAttrPath r)
  -- ^ Dot-reference into an attribute set, optionally providing an
  -- alternative if the key doesn't exist.
  --
  -- > NSelect Nothing  s (x :| [])                ~  s.x
  -- > NSelect (pure y) s (x :| [])                ~  s.x or y
  | NHasAttr !r !(NAttrPath r)
  -- ^ Ask if a set contains a given attribute path.
  --
  -- > NHasAttr s (x :| [])                        ~  s ? x
  | NAbs !(Params r) !r
  -- ^ A function literal (lambda abstraction).
  --
  -- > NAbs (Param "x") y                          ~  x: y
  | NLet ![Binding r] !r
  -- ^ Evaluate the second argument after introducing the bindings.
  --
  -- > NLet []                    x                ~  let in x
  -- > NLet [NamedVar x y _]      z                ~  let x = y; in z
  -- > NLet [Inherit Nothing x _] y                ~  let inherit x; in y
  | NIf !r !r !r
  -- ^ If-then-else statement.
  --
  -- > NIf x y z                                   ~  if x then y else z
  | NWith !r !r
  -- ^ Evaluate an attribute set, bring its bindings into scope, and
  -- evaluate the second argument.
  --
  -- > NWith x y                                   ~  with x; y
  | NAssert !r !r
  -- ^ Checks that the first argument is a predicate that is @true@ before evaluating the second argument.
  --
  -- > NAssert x y                                 ~  assert x; y
  | NSynHole !VarName
  -- ^ Syntactic hole.
  --
  -- See <https://github.com/haskell-nix/hnix/issues/197> for context.
  --
  -- > NSynHole "x"                                ~  ^x
  deriving
    ( Eq, Ord, Generic, Generic1
    , Typeable, Data, NFData, NFData1, Serialise, Binary, ToJSON, FromJSON
    , Functor, Foldable, Traversable
    , Show, Hashable
    )


$(deriveShow1 ''NExprF)
$(deriveEq1   ''NExprF)
$(deriveOrd1  ''NExprF)
--x $(deriveJSON1 defaultOptions ''NExprF)

deriving instance Hashable1 NExprF

-- ** lens traversals

$(makeTraversals ''NExprF)


-- ** type NExpr

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

-- | 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

instance Serialise NExpr

instance TH.Lift NExpr where
  lift =
    TH.dataToExpQ
      (\b ->
        do
          -- Binding on constructor ensures type match and gives type inference to TH.
          -- Reflection is the ability of a process to examine, introspect, and modify its own structure and behavior.
          -- Reflection is a key strategy in metaprogramming.
          -- <https://en.wikipedia.org/wiki/Reflective_programming>
          HRefl <-
            Reflection.eqTypeRep
              (Reflection.typeRep @Text)
              (Reflection.typeOf  b    )
          pure [| $(TH.lift b) |]
      )
#if MIN_VERSION_template_haskell(2,17,0)
  liftTyped = TH.unsafeCodeCoerce . TH.lift
#elif MIN_VERSION_template_haskell(2,16,0)
  liftTyped = TH.unsafeTExpCoerce . TH.lift
#endif


-- ** Methods

#if __GLASGOW_HASKELL__ >= 900
hashAt
  :: Functor f
  => VarName
  -> (Maybe v -> f (Maybe v))
  -> AttrSet v
  -> f (AttrSet v)
#else
hashAt :: VarName -> Lens' (AttrSet v) (Maybe v)
#endif
hashAt = alterF
 where
  alterF
    :: (Functor f)
    => VarName
    -> (Maybe v -> f (Maybe v))
    -> AttrSet v
    -> f (AttrSet v)
  alterF (coerce -> k) f m =
    maybe
      (MapL.delete k m)
      (\ v -> MapL.insert k v m)
      <$> f (MapL.lookup k m)

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

stringParts :: NString r -> [Antiquoted Text r]
stringParts (DoubleQuoted parts) = parts
stringParts (Indented _   parts) = parts

stripPositionInfo :: NExpr -> NExpr
stripPositionInfo = transport phi
 where
  transport f (Fix x) = Fix $ transport f <$> f x

  phi (NSet recur binds) = NSet recur $ erasePositions <$> binds
  phi (NLet binds body) = NLet (erasePositions <$> binds) body
  phi x                 = x

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

nullPos :: NSourcePos
nullPos = on (NSourcePos "<string>") (coerce . mkPos) 1 1

-- * Dead code

-- ** class NExprAnn

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

-- ** Other

ekey
  :: forall ann g
  . NExprAnn ann g
  => NonEmpty VarName
  -> NSourcePos
  -> Lens' (Fix g) (Maybe (Fix g))
ekey keys pos f e@(Fix x)
  | (NSet NonRecursive xs, ann) <- fromNExpr x =
    let
      vals :: [(Fix g, [VarName])]
      vals =
        do
          let keys' = NE.toList keys
          (ks, rest) <- zip (inits keys') (tails keys')
          handlePresence
            mempty
            (\ (j : js) ->
              do
                NamedVar ns v _p <- xs
                guard $ (j : js) == (NE.toList ns ^.. traverse . _StaticKey)
                pure (v, rest)
            )
            ks
    in
    case vals of
      ((v, []      ) : _) -> fromMaybe e <$> f (pure v)
      ((v, r : rest) : _) -> ekey (r :| rest) pos f v

      _                   ->
        maybe
          e
          (\ v ->
            let entry = NamedVar (StaticKey <$> keys) v pos in
            Fix $ toNExpr ( NSet mempty $ one entry <> xs, ann )
          )
        <$> f Nothing
ekey _ _ f e = fromMaybe e <$> f Nothing


getFreeVars :: NExpr -> Set VarName
getFreeVars e =
  case unFix e of
    (NConstant    _               ) -> mempty
    (NStr         string          ) -> mapFreeVars string
    (NSym         var             ) -> one var
    (NList        list            ) -> mapFreeVars list
    (NSet   NonRecursive  bindings) -> bindFreeVars bindings
    (NSet   Recursive     bindings) -> diffBetween bindFreeVars bindDefs bindings
    (NLiteralPath _               ) -> mempty
    (NEnvPath     _               ) -> mempty
    (NUnary       _    expr       ) -> getFreeVars expr
    (NApp         left right      ) -> collectFreeVars left right
    (NBinary      _    left right ) -> collectFreeVars left right
    (NSelect      orExpr expr path) ->
      Set.unions
        [ getFreeVars expr
        , pathFree path
        , getFreeVars `whenJust` orExpr
        ]
    (NHasAttr expr            path) -> getFreeVars expr <> pathFree path
    (NAbs     (Param varname) expr) -> Set.delete varname (getFreeVars expr)
    (NAbs (ParamSet varname _ pset) expr) ->
      Set.difference
        -- Include all free variables from the expression and the default arguments
        (getFreeVars expr <> Set.unions (getFreeVars <$> mapMaybe snd pset))
        -- But remove the argument name if existing, and all arguments in the parameter set
        ((one `whenJust` varname) <> Set.fromList (fst <$> pset))
    (NLet         bindings expr   ) ->
      Set.difference
        (getFreeVars expr <> bindFreeVars bindings)
        (bindDefs bindings)
    (NIf          cond th   el    ) -> Set.unions $ getFreeVars <$> [cond, th, el]
    -- Evaluation is needed to find out whether x is a "real" free variable in `with y; x`, we just include it
    -- This also makes sense because its value can be overridden by `x: with y; x`
    (NWith        set  expr       ) -> collectFreeVars set expr
    (NAssert      assertion expr  ) -> collectFreeVars assertion expr
    (NSynHole     _               ) -> mempty
 where
  diffBetween :: (a -> Set VarName) -> (a -> Set VarName) -> a -> Set VarName
  diffBetween g f b = Set.difference (g b) (f b)

  collectFreeVars :: NExpr -> NExpr -> Set VarName
  collectFreeVars = (<>) `on` getFreeVars

  bindDefs :: Foldable t => t (Binding NExpr) -> Set VarName
  bindDefs = foldMap bind1Def
   where
    bind1Def :: Binding r -> Set VarName
    bind1Def (Inherit   Nothing                  _    _) = mempty
    bind1Def (Inherit  (Just _                 ) keys _) = Set.fromList keys
    bind1Def (NamedVar (StaticKey  varname :| _) _    _) = one varname
    bind1Def (NamedVar (DynamicKey _       :| _) _    _) = mempty

  bindFreeVars :: Foldable t => t (Binding NExpr) -> Set VarName
  bindFreeVars = foldMap bind1Free
   where
    bind1Free :: Binding NExpr -> Set VarName
    bind1Free (Inherit  Nothing     keys _) = Set.fromList keys
    bind1Free (Inherit (Just scope) _    _) = getFreeVars scope
    bind1Free (NamedVar path        expr _) = pathFree path <> getFreeVars expr

  pathFree :: NAttrPath NExpr -> Set VarName
  pathFree = foldMap mapFreeVars

  mapFreeVars :: Foldable t => t NExpr -> Set VarName
  mapFreeVars = foldMap getFreeVars