{-# 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 #-}
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
#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
data NExprF r
= NConstant !NAtom
| NStr !(NString r)
| NSym !VarName
| NList ![r]
| NSet ![Binding r]
| NRecSet ![Binding r]
| NLiteralPath !FilePath
| NEnvPath !FilePath
| NUnary !NUnaryOp !r
| NBinary !NBinaryOp !r !r
| NSelect !r !(NAttrPath r) !(Maybe r)
| NHasAttr !r !(NAttrPath r)
| NAbs !(Params r) !r
| NLet ![Binding r] !r
| NIf !r !r !r
| NWith !r !r
| NAssert !r !r
| NSynHole !VarName
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
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
type NExpr = Fix NExprF
#ifdef MIN_VERSION_serialise
instance Serialise NExpr
#endif
data Binding r
= NamedVar !(NAttrPath r) !r !SourcePos
| Inherit !(Maybe r) ![NKeyName r] !SourcePos
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
data Params r
= Param !VarName
| ParamSet !(ParamSet r) !Bool !(Maybe VarName)
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
type ParamSet r = [(VarName, Maybe r)]
instance IsString (Params r) where
fromString = Param . fromString
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
data NString r
= DoubleQuoted ![Antiquoted Text r]
| Indented !Int ![Antiquoted Text r]
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
instance IsString (NString r) where
fromString "" = DoubleQuoted []
fromString string = DoubleQuoted [Plain $ pack string]
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
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
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
instance Functor NKeyName where
fmap = fmapDefault
instance Foldable NKeyName where
foldMap = foldMapDefault
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)
type NAttrPath r = NonEmpty (NKeyName r)
data NUnaryOp = NNeg | NNot
deriving (Eq, Ord, Enum, Bounded, Generic, Typeable, Data, Show, Read,
NFData, Hashable)
#ifdef MIN_VERSION_serialise
instance Serialise NUnaryOp
#endif
data NBinaryOp
= NEq
| NNEq
| NLt
| NLte
| NGt
| NGte
| NAnd
| NOr
| NImpl
| NUpdate
| NPlus
| NMinus
| NMult
| NDiv
| NConcat
| NApp
deriving (Eq, Ord, Enum, Bounded, Generic, Typeable, Data, Show, Read,
NFData, Hashable)
#ifdef MIN_VERSION_serialise
instance Serialise NBinaryOp
#endif
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 ''NString)
$(deriveJSON1 defaultOptions ''Params)
$(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)
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)