Use hpack and move all the Nix sources into a src/ directory
This commit is contained in:
parent
d9047cc216
commit
443129315d
134
Nix.hs
134
Nix.hs
|
@ -1,134 +0,0 @@
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE TupleSections #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
|
|
||||||
module Nix (eval, evalLoc, tracingEvalLoc, lint, runLintM) where
|
|
||||||
|
|
||||||
import Control.Applicative
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.Fix
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Control.Monad.Reader (MonadReader)
|
|
||||||
import Control.Monad.ST
|
|
||||||
import Control.Monad.ST.Unsafe
|
|
||||||
import Control.Monad.Trans.Reader
|
|
||||||
import qualified Data.ByteString as BS
|
|
||||||
import qualified Data.HashMap.Lazy as M
|
|
||||||
import Data.STRef
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Nix.Builtins
|
|
||||||
import qualified Nix.Eval as Eval
|
|
||||||
import Nix.Eval hiding (eval)
|
|
||||||
import Nix.Expr.Types (NExpr)
|
|
||||||
import Nix.Expr.Types.Annotated (NExprLoc)
|
|
||||||
import qualified Nix.Lint as Lint
|
|
||||||
import Nix.Lint hiding (lint)
|
|
||||||
import Nix.Monad.Instance
|
|
||||||
import Nix.Scope
|
|
||||||
import Nix.Stack
|
|
||||||
import Nix.Thunk
|
|
||||||
import Nix.Utils
|
|
||||||
import Nix.Value
|
|
||||||
|
|
||||||
-- | Evaluate a nix expression in the default context
|
|
||||||
evalTopLevelExpr :: forall e m. MonadBuiltins e m
|
|
||||||
=> Maybe FilePath -> NExpr -> m (NValueNF m)
|
|
||||||
evalTopLevelExpr mpath expr = do
|
|
||||||
base <- baseEnv
|
|
||||||
(normalForm =<<) $ pushScopes base $ case mpath of
|
|
||||||
Nothing -> Eval.evalExpr expr
|
|
||||||
Just path -> do
|
|
||||||
traceM $ "Setting __cur_file = " ++ show path
|
|
||||||
let ref = valueThunk @m $ NVLiteralPath path
|
|
||||||
pushScope (M.singleton "__cur_file" ref)
|
|
||||||
(Eval.evalExpr expr)
|
|
||||||
|
|
||||||
eval :: (MonadFix m, MonadIO m)
|
|
||||||
=> Maybe FilePath -> NExpr -> m (NValueNF (Lazy m))
|
|
||||||
eval mpath = runLazyM . evalTopLevelExpr mpath
|
|
||||||
|
|
||||||
-- | Evaluate a nix expression in the default context
|
|
||||||
evalTopLevelExprLoc :: forall e m. MonadBuiltins e m
|
|
||||||
=> Maybe FilePath -> NExprLoc -> m (NValueNF m)
|
|
||||||
evalTopLevelExprLoc mpath expr = do
|
|
||||||
base <- baseEnv
|
|
||||||
(normalForm =<<) $ pushScopes base $ case mpath of
|
|
||||||
Nothing -> framedEvalExpr Eval.eval expr
|
|
||||||
Just path -> do
|
|
||||||
traceM $ "Setting __cur_file = " ++ show path
|
|
||||||
let ref = valueThunk @m $ NVLiteralPath path
|
|
||||||
pushScope (M.singleton "__cur_file" ref)
|
|
||||||
(framedEvalExpr Eval.eval expr)
|
|
||||||
|
|
||||||
evalLoc :: (MonadFix m, MonadIO m)
|
|
||||||
=> Maybe FilePath -> NExprLoc -> m (NValueNF (Lazy m))
|
|
||||||
evalLoc mpath = runLazyM . evalTopLevelExprLoc mpath
|
|
||||||
|
|
||||||
tracingEvalLoc :: forall m. (MonadFix m, MonadIO m, Alternative m)
|
|
||||||
=> Maybe FilePath -> NExprLoc -> m (NValueNF (Lazy m))
|
|
||||||
tracingEvalLoc mpath expr = do
|
|
||||||
traced <- tracingEvalExpr Eval.eval expr
|
|
||||||
case mpath of
|
|
||||||
Nothing ->
|
|
||||||
runLazyM (normalForm =<< (`pushScopes` traced) =<< baseEnv)
|
|
||||||
Just path -> do
|
|
||||||
traceM $ "Setting __cur_file = " ++ show path
|
|
||||||
let ref = valueThunk @(Lazy m) $ NVLiteralPath path
|
|
||||||
let m = M.singleton "__cur_file" ref
|
|
||||||
runLazyM (baseEnv >>= (`pushScopes` pushScope m traced)
|
|
||||||
>>= normalForm)
|
|
||||||
|
|
||||||
newtype Lint s a = Lint
|
|
||||||
{ runLint :: ReaderT (Context (Lint s) (SThunk (Lint s))) (ST s) a }
|
|
||||||
deriving (Functor, Applicative, Monad, MonadFix,
|
|
||||||
MonadReader (Context (Lint s) (SThunk (Lint s))))
|
|
||||||
|
|
||||||
instance MonadVar (Lint s) where
|
|
||||||
type Var (Lint s) = STRef s
|
|
||||||
|
|
||||||
newVar x = Lint $ ReaderT $ \_ -> newSTRef x
|
|
||||||
readVar x = Lint $ ReaderT $ \_ -> readSTRef x
|
|
||||||
writeVar x y = Lint $ ReaderT $ \_ -> writeSTRef x y
|
|
||||||
atomicModifyVar x f = Lint $ ReaderT $ \_ -> do
|
|
||||||
res <- snd . f <$> readSTRef x
|
|
||||||
_ <- modifySTRef x (fst . f)
|
|
||||||
return res
|
|
||||||
|
|
||||||
instance MonadFile (Lint s) where
|
|
||||||
readFile x = Lint $ ReaderT $ \_ -> unsafeIOToST $ BS.readFile x
|
|
||||||
|
|
||||||
instance Eval.MonadExpr (SThunk (Lint s))
|
|
||||||
(STRef s (NSymbolicF (NTypeF (Lint s) (SThunk (Lint s)))))
|
|
||||||
(Lint s) where
|
|
||||||
embedSet s = mkSymbolic [TSet (Just s)]
|
|
||||||
projectSet = unpackSymbolic >=> \case
|
|
||||||
NMany [TSet s] -> return s
|
|
||||||
_ -> return Nothing
|
|
||||||
projectSetWithPos = unpackSymbolic >=> \case
|
|
||||||
NMany [TSet s] -> return $ (, M.empty) <$> s
|
|
||||||
_ -> return Nothing
|
|
||||||
|
|
||||||
type MText (Lint s) = Text
|
|
||||||
|
|
||||||
wrapText = return
|
|
||||||
unwrapText = return
|
|
||||||
|
|
||||||
embedText = const $ mkSymbolic [TStr]
|
|
||||||
projectText = const $ return Nothing
|
|
||||||
|
|
||||||
runLintM :: Lint s a -> ST s a
|
|
||||||
runLintM = flip runReaderT (Context emptyScopes []) . runLint
|
|
||||||
|
|
||||||
symbolicBaseEnv :: Monad m => m (Scopes m (SThunk m))
|
|
||||||
symbolicBaseEnv = return [] -- jww (2018-04-02): TODO
|
|
||||||
|
|
||||||
lint :: NExpr -> ST s (Symbolic (Lint s))
|
|
||||||
lint expr = runLintM $ symbolicBaseEnv
|
|
||||||
>>= (`pushScopes` Lint.lintExpr expr)
|
|
63
Nix/Atoms.hs
63
Nix/Atoms.hs
|
@ -1,63 +0,0 @@
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
module Nix.Atoms where
|
|
||||||
|
|
||||||
import Data.Data
|
|
||||||
import Data.HashMap.Strict (HashMap)
|
|
||||||
import Data.Text (Text, pack)
|
|
||||||
import GHC.Generics
|
|
||||||
|
|
||||||
-- | Atoms are values that evaluate to themselves. This means that
|
|
||||||
-- they appear in both the parsed AST (in the form of literals) and
|
|
||||||
-- the evaluated form.
|
|
||||||
data NAtom
|
|
||||||
-- | An integer. The c nix implementation currently only supports
|
|
||||||
-- integers that fit in the range of 'Int64'.
|
|
||||||
= NInt !Integer
|
|
||||||
-- | A floating point number
|
|
||||||
| NFloat !Float
|
|
||||||
-- | Booleans.
|
|
||||||
| NBool !Bool
|
|
||||||
-- | Null values. There's only one of this variant.
|
|
||||||
| NNull
|
|
||||||
-- | URIs, which are just string literals, but do not need quotes.
|
|
||||||
| NUri !Text
|
|
||||||
deriving (Eq, Ord, Generic, Typeable, Data, Show)
|
|
||||||
|
|
||||||
class ToAtom t where
|
|
||||||
toAtom :: t -> NAtom
|
|
||||||
|
|
||||||
instance ToAtom Bool where toAtom = NBool
|
|
||||||
instance ToAtom Int where toAtom = NInt . fromIntegral
|
|
||||||
instance ToAtom Integer where toAtom = NInt
|
|
||||||
|
|
||||||
class FromAtom t where
|
|
||||||
fromAtom :: NAtom -> t
|
|
||||||
fromAtoms :: [NAtom] -> t
|
|
||||||
fromAtomSet :: HashMap Text NAtom -> t
|
|
||||||
|
|
||||||
-- | Convert a primitive into something which can be made from a
|
|
||||||
-- constant. So for example `convert 1 :: Expression`
|
|
||||||
convert :: (ToAtom prim, FromAtom t) => prim -> t
|
|
||||||
convert = fromAtom . toAtom
|
|
||||||
|
|
||||||
-- | Conversion to environment variables for constants.
|
|
||||||
atomToEnvString :: NAtom -> Text
|
|
||||||
atomToEnvString = \case
|
|
||||||
NInt i -> pack $ show i
|
|
||||||
NFloat f -> pack $ show f
|
|
||||||
NBool True -> "1"
|
|
||||||
NBool False -> ""
|
|
||||||
NNull -> ""
|
|
||||||
NUri uri -> uri
|
|
||||||
|
|
||||||
-- | Translate an atom into its nix representation.
|
|
||||||
atomText :: NAtom -> Text
|
|
||||||
atomText (NInt i) = pack (show i)
|
|
||||||
atomText (NFloat f) = pack (show f)
|
|
||||||
atomText (NBool b) = if b then "true" else "false"
|
|
||||||
atomText NNull = "null"
|
|
||||||
atomText (NUri uri) = uri
|
|
894
Nix/Builtins.hs
894
Nix/Builtins.hs
|
@ -1,894 +0,0 @@
|
||||||
{-# LANGUAGE ConstraintKinds #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE FunctionalDependencies #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE MultiWayIf #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
|
||||||
|
|
||||||
{-# OPTIONS_GHC -Wno-missing-signatures #-}
|
|
||||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
|
||||||
|
|
||||||
module Nix.Builtins (MonadBuiltins, baseEnv) where
|
|
||||||
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.Fix
|
|
||||||
import Control.Monad.ListM (sortByM)
|
|
||||||
import Control.Monad.Reader
|
|
||||||
import qualified Crypto.Hash.MD5 as MD5
|
|
||||||
import qualified Crypto.Hash.SHA1 as SHA1
|
|
||||||
import qualified Crypto.Hash.SHA256 as SHA256
|
|
||||||
import qualified Crypto.Hash.SHA512 as SHA512
|
|
||||||
import Data.Aeson (toJSON)
|
|
||||||
import qualified Data.Aeson as A
|
|
||||||
import qualified Data.Aeson.Encoding as A
|
|
||||||
import Data.Align (alignWith)
|
|
||||||
import Data.Array
|
|
||||||
import Data.ByteString (ByteString)
|
|
||||||
import Data.ByteString.Base16 as Base16
|
|
||||||
import qualified Data.ByteString.Lazy as LBS
|
|
||||||
import Data.Char (isDigit)
|
|
||||||
import Data.Coerce
|
|
||||||
import Data.Foldable (foldlM)
|
|
||||||
import Data.Functor.Compose
|
|
||||||
import Data.HashMap.Lazy (HashMap)
|
|
||||||
import qualified Data.HashMap.Lazy as M
|
|
||||||
import qualified Data.HashMap.Strict.InsOrd as OM
|
|
||||||
import Data.List
|
|
||||||
import Data.Maybe
|
|
||||||
import Data.Scientific
|
|
||||||
import Data.Semigroup
|
|
||||||
import Data.Text (Text)
|
|
||||||
import qualified Data.Text as Text
|
|
||||||
import Data.Text.Encoding
|
|
||||||
import qualified Data.Text.Lazy as LazyText
|
|
||||||
import qualified Data.Text.Lazy.Builder as Builder
|
|
||||||
import Data.These (fromThese)
|
|
||||||
import Data.Traversable (mapM)
|
|
||||||
import qualified Data.Vector as V
|
|
||||||
import GHC.Stack.Types (HasCallStack)
|
|
||||||
import Nix.Atoms
|
|
||||||
import Nix.Eval
|
|
||||||
import Nix.Expr.Types
|
|
||||||
import Nix.Expr.Types.Annotated
|
|
||||||
import Nix.Monad
|
|
||||||
import Nix.Pretty
|
|
||||||
import Nix.Scope
|
|
||||||
import Nix.Stack
|
|
||||||
import Nix.Thunk
|
|
||||||
import Nix.Utils
|
|
||||||
import Nix.Value
|
|
||||||
import Nix.XML
|
|
||||||
import System.FilePath
|
|
||||||
import System.Posix.Files
|
|
||||||
import Text.Regex.TDFA
|
|
||||||
|
|
||||||
type MonadBuiltins e m =
|
|
||||||
(MonadEval e m, MonadNix m, MonadFix m, MonadFile m, MonadVar m)
|
|
||||||
|
|
||||||
baseEnv :: MonadBuiltins e m => m (Scopes m (NThunk m))
|
|
||||||
baseEnv = do
|
|
||||||
ref <- thunk $ flip NVSet M.empty <$> builtins
|
|
||||||
let pos = repeatingThunk curPos -- re-evaluate each time it's forced
|
|
||||||
lst <- ([ ("builtins", ref)
|
|
||||||
, ("__curPos", pos)
|
|
||||||
] ++)
|
|
||||||
<$> topLevelBuiltins
|
|
||||||
pushScope (M.fromList lst) currentScopes
|
|
||||||
where
|
|
||||||
topLevelBuiltins = map mapping . filter isTopLevel <$> builtinsList
|
|
||||||
|
|
||||||
builtins :: MonadBuiltins e m => m (ValueSet m)
|
|
||||||
builtins = M.fromList . map mapping <$> builtinsList
|
|
||||||
|
|
||||||
data BuiltinType = Normal | TopLevel
|
|
||||||
data Builtin m = Builtin
|
|
||||||
{ kind :: BuiltinType
|
|
||||||
, mapping :: (Text, NThunk m)
|
|
||||||
}
|
|
||||||
|
|
||||||
isTopLevel :: Builtin m -> Bool
|
|
||||||
isTopLevel b = case kind b of Normal -> False; TopLevel -> True
|
|
||||||
|
|
||||||
builtinsList :: forall e m. MonadBuiltins e m => m [ Builtin m ]
|
|
||||||
builtinsList = sequence [
|
|
||||||
pure $ Builtin Normal ("nixVersion", valueThunk $ NVStr "2.0" mempty)
|
|
||||||
|
|
||||||
, add TopLevel "toString" toString
|
|
||||||
, add TopLevel "import" import_
|
|
||||||
, add2 TopLevel "map" map_
|
|
||||||
, add' TopLevel "baseNameOf" (arity1 baseNameOf)
|
|
||||||
, add TopLevel "dirOf" dirOf
|
|
||||||
, add2 TopLevel "removeAttrs" removeAttrs
|
|
||||||
, add TopLevel "isNull" isNull
|
|
||||||
, add TopLevel "abort" throw_ -- for now
|
|
||||||
, add TopLevel "throw" throw_
|
|
||||||
, add2 TopLevel "scopedImport" scopedImport
|
|
||||||
, add Normal "getEnv" getEnv_
|
|
||||||
, add2 Normal "hasAttr" hasAttr
|
|
||||||
, add2 Normal "getAttr" getAttr
|
|
||||||
, add2 Normal "unsafeGetAttrPos" unsafeGetAttrPos
|
|
||||||
, add2 Normal "any" any_
|
|
||||||
, add2 Normal "all" all_
|
|
||||||
, add3 Normal "foldl'" foldl'_
|
|
||||||
, add Normal "head" head_
|
|
||||||
, add Normal "tail" tail_
|
|
||||||
, add Normal "splitVersion" splitVersion_
|
|
||||||
, add2 Normal "compareVersions" compareVersions_
|
|
||||||
, add2 Normal "match" match_
|
|
||||||
--TODO: Support floats for `add` and `sub`
|
|
||||||
, add' Normal "add" (arity2 ((+) @Integer))
|
|
||||||
, add' Normal "sub" (arity2 ((-) @Integer))
|
|
||||||
, add' Normal "parseDrvName" parseDrvName
|
|
||||||
, add' Normal "substring" substring
|
|
||||||
, add' Normal "stringLength" (arity1 Text.length)
|
|
||||||
, add Normal "length" length_
|
|
||||||
, add Normal "attrNames" attrNames
|
|
||||||
, add Normal "attrValues" attrValues
|
|
||||||
, add2 Normal "catAttrs" catAttrs
|
|
||||||
, add' Normal "concatStringsSep" (arity2 Text.intercalate)
|
|
||||||
, add Normal "unsafeDiscardStringContext" unsafeDiscardStringContext
|
|
||||||
, add2 Normal "seq" seq_
|
|
||||||
, add2 Normal "deepSeq" deepSeq
|
|
||||||
, add2 Normal "elem" elem_
|
|
||||||
, add2 Normal "elemAt" elemAt_
|
|
||||||
, add2 Normal "genList" genList
|
|
||||||
, add2 Normal "filter" filter_
|
|
||||||
, add' Normal "replaceStrings" replaceStrings
|
|
||||||
, add Normal "pathExists" pathExists_
|
|
||||||
, add Normal "toPath" toPath
|
|
||||||
, add Normal "isAttrs" isAttrs
|
|
||||||
, add Normal "isList" isList
|
|
||||||
, add Normal "isFunction" isFunction
|
|
||||||
, add Normal "isString" isString
|
|
||||||
, add Normal "isInt" isInt
|
|
||||||
, add Normal "isFloat" isFloat
|
|
||||||
, add Normal "isBool" isBool
|
|
||||||
, add2 Normal "sort" sort_
|
|
||||||
, add2 Normal "lessThan" lessThan
|
|
||||||
, add Normal "concatLists" concatLists
|
|
||||||
, add Normal "listToAttrs" listToAttrs
|
|
||||||
, add2 Normal "intersectAttrs" intersectAttrs
|
|
||||||
, add Normal "functionArgs" functionArgs
|
|
||||||
, add' Normal "hashString" hashString
|
|
||||||
, add Normal "readFile" readFile_
|
|
||||||
, add Normal "readDir" readDir_
|
|
||||||
, add' Normal "toJSON"
|
|
||||||
(arity1 $ decodeUtf8 . LBS.toStrict . A.encodingToLazyByteString
|
|
||||||
. toEncodingSorted)
|
|
||||||
, add Normal "fromJSON" fromJSON
|
|
||||||
, add Normal "toXML" toXML_
|
|
||||||
, add Normal "typeOf" typeOf
|
|
||||||
, add2 Normal "partition" partition_
|
|
||||||
, add0 Normal "currentSystem" currentSystem
|
|
||||||
]
|
|
||||||
where
|
|
||||||
wrap t n f = Builtin t (n, f)
|
|
||||||
|
|
||||||
arity1 f = Prim . pure . f
|
|
||||||
arity2 f = ((Prim . pure) .) . f
|
|
||||||
|
|
||||||
add0 t n v = wrap t n <$> thunk v
|
|
||||||
add t n v = wrap t n <$> thunk (builtin (Text.unpack n) v)
|
|
||||||
add2 t n v = wrap t n <$> thunk (builtin2 (Text.unpack n) v)
|
|
||||||
add3 t n v = wrap t n <$> thunk (builtin3 (Text.unpack n) v)
|
|
||||||
|
|
||||||
add' :: ToBuiltin m a => BuiltinType -> Text -> a -> m (Builtin m)
|
|
||||||
add' t n v = wrap t n <$> thunk (toBuiltin (Text.unpack n) v)
|
|
||||||
|
|
||||||
-- Helpers
|
|
||||||
|
|
||||||
mkBool :: Monad m => Bool -> m (NValue m)
|
|
||||||
mkBool = return . NVConstant . NBool
|
|
||||||
|
|
||||||
extractBool :: MonadBuiltins e m => NValue m -> m Bool
|
|
||||||
extractBool = \case
|
|
||||||
NVConstant (NBool b) -> return b
|
|
||||||
_ -> throwError "Not a boolean constant"
|
|
||||||
|
|
||||||
extractInt :: MonadBuiltins e m => NValue m -> m Int
|
|
||||||
extractInt = \case
|
|
||||||
NVConstant (NInt b) -> return $ fromIntegral b
|
|
||||||
_ -> throwError "Not an integer constant"
|
|
||||||
|
|
||||||
apply :: MonadBuiltins e m
|
|
||||||
=> NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
apply f arg = force f $ \f' -> pure f' `evalApp` arg
|
|
||||||
|
|
||||||
-- Primops
|
|
||||||
|
|
||||||
deltaInfo :: Delta -> (Text, Int, Int)
|
|
||||||
deltaInfo = \case
|
|
||||||
Columns c _ -> ("<string>", 1, fromIntegral c + 1)
|
|
||||||
Tab {} -> ("<string>", 1, 1)
|
|
||||||
Lines l _ _ _ -> ("<string>", fromIntegral l + 1, 1)
|
|
||||||
Directed fn l c _ _ -> (decodeUtf8 fn,
|
|
||||||
fromIntegral l + 1, fromIntegral c + 1)
|
|
||||||
|
|
||||||
posFromDelta :: Delta -> NValue m
|
|
||||||
posFromDelta (deltaInfo -> (f, l, c)) =
|
|
||||||
flip NVSet M.empty $ M.fromList
|
|
||||||
[ ("file", valueThunk $ NVStr f mempty)
|
|
||||||
, ("line", valueThunk $ NVConstant (NInt (fromIntegral l)))
|
|
||||||
, ("column", valueThunk $ NVConstant (NInt (fromIntegral c)))
|
|
||||||
]
|
|
||||||
|
|
||||||
curPos :: forall e m. Framed e m => m (NValue m)
|
|
||||||
curPos = do
|
|
||||||
Compose (Ann (SrcSpan delta _) _):_ <-
|
|
||||||
asks (mapMaybe (either (const Nothing) Just)
|
|
||||||
. view @_ @Frames hasLens)
|
|
||||||
return $ posFromDelta delta
|
|
||||||
|
|
||||||
toString :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
toString str = do
|
|
||||||
(s, d) <- force str $ normalForm >=> valueText False
|
|
||||||
return $ NVStr s d
|
|
||||||
|
|
||||||
hasAttr :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
hasAttr x y = force x $ \x' -> force y $ \y' -> case (x', y') of
|
|
||||||
(NVStr key _, NVSet aset _) ->
|
|
||||||
return . NVConstant . NBool $ M.member key aset
|
|
||||||
(x, y) -> throwError $ "Invalid types for builtin.hasAttr: "
|
|
||||||
++ show (void x, void y)
|
|
||||||
|
|
||||||
getAttr :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
getAttr x y = force x $ \x' -> force y $ \y' -> case (x', y') of
|
|
||||||
(NVStr key _, NVSet aset _) -> case M.lookup key aset of
|
|
||||||
Nothing -> throwError $ "getAttr: field does not exist: "
|
|
||||||
++ Text.unpack key
|
|
||||||
Just action -> force action pure
|
|
||||||
(x, y) -> throwError $ "Invalid types for builtin.getAttr: "
|
|
||||||
++ show (void x, void y)
|
|
||||||
|
|
||||||
unsafeGetAttrPos :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
unsafeGetAttrPos x y = force x $ \x' -> force y $ \y' -> case (x', y') of
|
|
||||||
(NVStr key _, NVSet _ apos) -> case M.lookup key apos of
|
|
||||||
Nothing ->
|
|
||||||
throwError $ "unsafeGetAttrPos: field '" ++ Text.unpack key
|
|
||||||
++ "' does not exist in attr set: " ++ show apos
|
|
||||||
Just delta -> return $ posFromDelta delta
|
|
||||||
(x, y) -> throwError $ "Invalid types for builtin.unsafeGetAttrPos: "
|
|
||||||
++ show (void x, void y)
|
|
||||||
|
|
||||||
length_ :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
length_ = flip force $ \case
|
|
||||||
NVList l -> return $ NVConstant $ NInt (fromIntegral (length l))
|
|
||||||
arg -> throwError $ "builtins.length takes a list, not a "
|
|
||||||
++ show (void arg)
|
|
||||||
|
|
||||||
anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
|
|
||||||
anyM _ [] = return False
|
|
||||||
anyM p (x:xs) = do
|
|
||||||
q <- p x
|
|
||||||
if q then return True
|
|
||||||
else anyM p xs
|
|
||||||
|
|
||||||
any_ :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
any_ pred = flip force $ \case
|
|
||||||
NVList l ->
|
|
||||||
mkBool =<< anyM extractBool =<< mapM (apply pred) l
|
|
||||||
arg -> throwError $ "builtins.any takes a list as second argument, not a "
|
|
||||||
++ show (void arg)
|
|
||||||
|
|
||||||
allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
|
|
||||||
allM _ [] = return True
|
|
||||||
allM p (x:xs) = do
|
|
||||||
q <- p x
|
|
||||||
if q then allM p xs
|
|
||||||
else return False
|
|
||||||
|
|
||||||
all_ :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
all_ pred = flip force $ \case
|
|
||||||
NVList l ->
|
|
||||||
mkBool =<< allM extractBool =<< mapM (apply pred) l
|
|
||||||
arg -> throwError $ "builtins.all takes a list as second argument, not a "
|
|
||||||
++ show (void arg)
|
|
||||||
|
|
||||||
--TODO: Strictness
|
|
||||||
foldl'_ :: MonadBuiltins e m => NThunk m -> NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
foldl'_ f z = flip force $ \case
|
|
||||||
NVList vals -> (`force` pure) =<< foldlM go z vals
|
|
||||||
arg -> throwError $ "builtins.foldl' takes a list as third argument, not a "
|
|
||||||
++ show (void arg)
|
|
||||||
where
|
|
||||||
go b a = thunk $ f `apply` a `evalApp` b
|
|
||||||
|
|
||||||
head_ :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
head_ = flip force $ \case
|
|
||||||
NVList vals -> case vals of
|
|
||||||
[] -> throwError "builtins.head: empty list"
|
|
||||||
h:_ -> force h pure
|
|
||||||
_ -> throwError "builtins.head: not a list"
|
|
||||||
|
|
||||||
tail_ :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
tail_ = flip force $ \case
|
|
||||||
NVList vals -> case vals of
|
|
||||||
[] -> throwError "builtins.tail: empty list"
|
|
||||||
_:t -> return $ NVList t
|
|
||||||
_ -> throwError "builtins.tail: not a list"
|
|
||||||
|
|
||||||
data VersionComponent
|
|
||||||
= VersionComponent_Pre -- ^ The string "pre"
|
|
||||||
| VersionComponent_String Text -- ^ A string other than "pre"
|
|
||||||
| VersionComponent_Number Integer -- ^ A number
|
|
||||||
deriving (Show, Read, Eq, Ord)
|
|
||||||
|
|
||||||
versionComponentToString :: VersionComponent -> Text
|
|
||||||
versionComponentToString = \case
|
|
||||||
VersionComponent_Pre -> "pre"
|
|
||||||
VersionComponent_String s -> s
|
|
||||||
VersionComponent_Number n -> Text.pack $ show n
|
|
||||||
|
|
||||||
-- | Based on https://github.com/NixOS/nix/blob/4ee4fda521137fed6af0446948b3877e0c5db803/src/libexpr/names.cc#L44
|
|
||||||
versionComponentSeparators :: String
|
|
||||||
versionComponentSeparators = ".-"
|
|
||||||
|
|
||||||
splitVersion :: Text -> [VersionComponent]
|
|
||||||
splitVersion s = case Text.uncons s of
|
|
||||||
Nothing -> []
|
|
||||||
Just (h, t)
|
|
||||||
| h `elem` versionComponentSeparators -> splitVersion t
|
|
||||||
| isDigit h ->
|
|
||||||
let (digits, rest) = Text.span isDigit s
|
|
||||||
in VersionComponent_Number (read $ Text.unpack digits) : splitVersion rest
|
|
||||||
| otherwise ->
|
|
||||||
let (chars, rest) = Text.span (\c -> not $ isDigit c || c `elem` versionComponentSeparators) s
|
|
||||||
thisComponent = case chars of
|
|
||||||
"pre" -> VersionComponent_Pre
|
|
||||||
x -> VersionComponent_String x
|
|
||||||
in thisComponent : splitVersion rest
|
|
||||||
|
|
||||||
splitVersion_ :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
splitVersion_ = flip force $ \case
|
|
||||||
NVStr s _ -> do
|
|
||||||
let vals = flip map (splitVersion s) $ \c ->
|
|
||||||
valueThunk $ NVStr (versionComponentToString c) mempty
|
|
||||||
return $ NVList vals
|
|
||||||
_ -> throwError "builtins.splitVersion: not a string"
|
|
||||||
|
|
||||||
compareVersions :: Text -> Text -> Ordering
|
|
||||||
compareVersions s1 s2 =
|
|
||||||
mconcat $ alignWith f (splitVersion s1) (splitVersion s2)
|
|
||||||
where
|
|
||||||
z = VersionComponent_String ""
|
|
||||||
f = uncurry compare . fromThese z z
|
|
||||||
|
|
||||||
compareVersions_ :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
compareVersions_ t1 t2 = force t1 $ \v1 -> force t2 $ \v2 -> case (v1, v2) of
|
|
||||||
(NVStr s1 _, NVStr s2 _) ->
|
|
||||||
return $ NVConstant $ NInt $ case compareVersions s1 s2 of
|
|
||||||
LT -> -1
|
|
||||||
EQ -> 0
|
|
||||||
GT -> 1
|
|
||||||
_ -> throwError "builtins.splitVersion: not a string"
|
|
||||||
|
|
||||||
splitDrvName :: Text -> (Text, Text)
|
|
||||||
splitDrvName s =
|
|
||||||
let sep = "-"
|
|
||||||
pieces = Text.splitOn sep s
|
|
||||||
isFirstVersionPiece p = case Text.uncons p of
|
|
||||||
Just (h, _) | isDigit h -> True
|
|
||||||
_ -> False
|
|
||||||
-- Like 'break', but always puts the first item into the first result
|
|
||||||
-- list
|
|
||||||
breakAfterFirstItem :: (a -> Bool) -> [a] -> ([a], [a])
|
|
||||||
breakAfterFirstItem f = \case
|
|
||||||
h : t ->
|
|
||||||
let (a, b) = break f t
|
|
||||||
in (h : a, b)
|
|
||||||
[] -> ([], [])
|
|
||||||
(namePieces, versionPieces) =
|
|
||||||
breakAfterFirstItem isFirstVersionPiece pieces
|
|
||||||
in (Text.intercalate sep namePieces, Text.intercalate sep versionPieces)
|
|
||||||
|
|
||||||
parseDrvName :: Applicative m => Text -> Prim m (HashMap Text Text)
|
|
||||||
parseDrvName s = Prim $ pure $ M.fromList [("name", name), ("version", version)]
|
|
||||||
where (name, version) = splitDrvName s
|
|
||||||
|
|
||||||
match_ :: forall e m. MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
match_ pat str = force pat $ \pat' -> force str $ \str' ->
|
|
||||||
case (pat', str') of
|
|
||||||
-- jww (2018-04-05): We should create a fundamental type for compiled
|
|
||||||
-- regular expressions if it turns out they get used often.
|
|
||||||
(NVStr p _, NVStr s _) -> return $ NVList $
|
|
||||||
let re = makeRegex (encodeUtf8 p) :: Regex
|
|
||||||
in case matchOnceText re (encodeUtf8 s) of
|
|
||||||
Just ("", sarr, "") -> let s = map fst (elems sarr) in
|
|
||||||
map (valueThunk @m . flip NVStr mempty . decodeUtf8)
|
|
||||||
(if length s > 1 then tail s else s)
|
|
||||||
_ -> []
|
|
||||||
(p, s) ->
|
|
||||||
throwError $ "builtins.match: expected a regex"
|
|
||||||
++ " and a string, but got: " ++ show (p, s)
|
|
||||||
|
|
||||||
substring :: Applicative m => Int -> Int -> Text -> Prim m Text
|
|
||||||
substring start len =
|
|
||||||
if start < 0 --NOTE: negative values of 'len' are OK
|
|
||||||
then error $ "builtins.substring: negative start position: " ++ show start
|
|
||||||
else Prim . pure . Text.take len . Text.drop start
|
|
||||||
|
|
||||||
attrNames :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
attrNames = flip force $ \case
|
|
||||||
NVSet m _ -> toValue $ sort $ M.keys m
|
|
||||||
v -> error $ "builtins.attrNames: Expected attribute set, got "
|
|
||||||
++ showValue v
|
|
||||||
|
|
||||||
attrValues :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
attrValues = flip force $ \case
|
|
||||||
NVSet m _ -> return $ NVList $ fmap snd $ sortOn fst $ M.toList m
|
|
||||||
v -> error $ "builtins.attrValues: Expected attribute set, got "
|
|
||||||
++ showValue v
|
|
||||||
|
|
||||||
map_ :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
map_ f = flip force $ \case
|
|
||||||
NVList l -> NVList <$> traverse (fmap valueThunk . apply f) l
|
|
||||||
v -> error $ "map: Expected list, got " ++ showValue v
|
|
||||||
|
|
||||||
filter_ :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
filter_ f = flip force $ \case
|
|
||||||
NVList l -> NVList <$> filterM (extractBool <=< apply f) l
|
|
||||||
v -> error $ "map: Expected list, got " ++ showValue v
|
|
||||||
|
|
||||||
catAttrs :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
catAttrs attrName lt = force lt $ \case
|
|
||||||
NVList l -> fmap (NVList . catMaybes) $ forM l $ flip force $ \case
|
|
||||||
NVSet m _ -> force attrName $ \case
|
|
||||||
NVStr n _ -> return $ M.lookup n m
|
|
||||||
v -> throwError $ "builtins.catAttrs: Expected a string, got "
|
|
||||||
++ showValue v
|
|
||||||
v -> throwError $ "builtins.catAttrs: Expected a set, got "
|
|
||||||
++ showValue v
|
|
||||||
v -> throwError $ "builtins.catAttrs: Expected a list, got "
|
|
||||||
++ showValue v
|
|
||||||
|
|
||||||
--TODO: Make this have similar logic to dirOf
|
|
||||||
baseNameOf :: Text -> Text
|
|
||||||
baseNameOf = Text.pack . takeFileName . Text.unpack
|
|
||||||
|
|
||||||
dirOf :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
dirOf = flip force $ \case
|
|
||||||
--TODO: Only allow strings that represent absolute paths
|
|
||||||
NVStr path ctx -> pure $ NVStr (Text.pack $ takeDirectory $ Text.unpack path) ctx
|
|
||||||
NVLiteralPath path -> pure $ NVLiteralPath $ takeDirectory path
|
|
||||||
--TODO: NVEnvPath
|
|
||||||
v -> throwError $ "dirOf: expected string or path, got " ++ showValue v
|
|
||||||
|
|
||||||
unsafeDiscardStringContext :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
unsafeDiscardStringContext = flip force $ \case
|
|
||||||
NVStr s _ -> pure $ NVStr s mempty
|
|
||||||
v -> throwError $ "builtins.unsafeDiscardStringContext: "
|
|
||||||
++ "Expected a string, got " ++ showValue v
|
|
||||||
|
|
||||||
seq_ :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
seq_ a b = force a (const (force b pure))
|
|
||||||
|
|
||||||
deepSeq :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
deepSeq a b = do
|
|
||||||
-- We evaluate 'a' only for its effects, so data cycles are ignored.
|
|
||||||
_ <- forceEffects (coerce a) $ \a' ->
|
|
||||||
normalFormBy (forceEffects . coerce) a'
|
|
||||||
|
|
||||||
-- Then we evaluate the other argument to deepseq, thus this function
|
|
||||||
-- should always produce a result (unlike applying 'deepseq' on infinitely
|
|
||||||
-- recursive data structures in Haskell).
|
|
||||||
force b pure
|
|
||||||
|
|
||||||
elem_ :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
elem_ x xs = force xs $ \case
|
|
||||||
NVList l -> toValue =<< anyM (thunkEq x) l
|
|
||||||
v -> throwError $ "builtins.elem: Expected a list, got " ++ showValue v
|
|
||||||
|
|
||||||
elemAt_ :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
elemAt_ xs n = force n $ extractInt >=> \n' -> force xs $ \case
|
|
||||||
NVList l | n' < length l -> force (l !! n') pure
|
|
||||||
| otherwise ->
|
|
||||||
throwError $ "builtins.elem: Index " ++ show n'
|
|
||||||
++ " too large for list of length " ++ show (length l)
|
|
||||||
v -> throwError $ "builtins.elem: Expected a list, got " ++ showValue v
|
|
||||||
|
|
||||||
genList :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
genList generator length = force length $ \case
|
|
||||||
NVConstant (NInt n) | n >= 0 -> fmap NVList $ forM [0 .. n - 1] $ \i ->
|
|
||||||
thunk $ apply generator =<< valueThunk <$> toValue i
|
|
||||||
v -> throwError $ "builtins.genList: Expected a non-negative number, got "
|
|
||||||
++ showValue v
|
|
||||||
|
|
||||||
--TODO: Preserve string context
|
|
||||||
replaceStrings :: MonadBuiltins e m => [Text] -> [Text] -> Text -> Prim m Text
|
|
||||||
replaceStrings from to s = Prim $ do
|
|
||||||
when (length from /= length to) $
|
|
||||||
throwError $ "'from' and 'to' arguments to 'replaceStrings'"
|
|
||||||
++ " have different lengths"
|
|
||||||
let lookupPrefix s = do
|
|
||||||
(prefix, replacement) <-
|
|
||||||
find ((`Text.isPrefixOf` s) . fst) $ zip from to
|
|
||||||
let rest = Text.drop (Text.length prefix) s
|
|
||||||
return (prefix, replacement, rest)
|
|
||||||
finish = LazyText.toStrict . Builder.toLazyText
|
|
||||||
go orig result = case lookupPrefix orig of
|
|
||||||
Nothing -> case Text.uncons orig of
|
|
||||||
Nothing -> finish result
|
|
||||||
Just (h, t) -> go t $ result <> Builder.singleton h
|
|
||||||
Just (prefix, replacement, rest) -> case prefix of
|
|
||||||
"" -> case Text.uncons rest of
|
|
||||||
Nothing -> finish $ result <> Builder.fromText replacement
|
|
||||||
Just (h, t) -> go t $ mconcat
|
|
||||||
[ result
|
|
||||||
, Builder.fromText replacement
|
|
||||||
, Builder.singleton h
|
|
||||||
]
|
|
||||||
_ -> go rest $ result <> Builder.fromText replacement
|
|
||||||
return $ go s mempty
|
|
||||||
|
|
||||||
removeAttrs :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
removeAttrs set list = fromThunk @[Text] list $ \toRemove ->
|
|
||||||
force set $ \case
|
|
||||||
NVSet m p -> return $ NVSet (go m toRemove) (go p toRemove)
|
|
||||||
v -> throwError $ "removeAttrs: expected set, got " ++ showValue v
|
|
||||||
where
|
|
||||||
go = foldl' (flip M.delete)
|
|
||||||
|
|
||||||
intersectAttrs :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
intersectAttrs set1 set2 = force set1 $ \set1' -> force set2 $ \set2' ->
|
|
||||||
case (set1', set2') of
|
|
||||||
(NVSet s1 p1, NVSet s2 p2) ->
|
|
||||||
return $ NVSet (s2 `M.intersection` s1) (p2 `M.intersection` p1)
|
|
||||||
(v1, v2) ->
|
|
||||||
throwError $ "builtins.intersectAttrs: expected two sets, got "
|
|
||||||
++ showValue v1 ++ " and " ++ showValue v2
|
|
||||||
|
|
||||||
functionArgs :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
functionArgs fun = force fun $ \case
|
|
||||||
NVClosure _ p _ ->
|
|
||||||
-- jww (2018-04-05): Should we preserve the location where the
|
|
||||||
-- function arguments were declared for __unsafeGetAttrPos?
|
|
||||||
return $ flip NVSet M.empty $ valueThunk . NVConstant . NBool <$>
|
|
||||||
case p of
|
|
||||||
Param name -> M.singleton name False
|
|
||||||
ParamSet s _ _ -> isJust <$> OM.toHashMap s
|
|
||||||
v -> throwError $ "builtins.functionArgs: expected function, got "
|
|
||||||
++ showValue v
|
|
||||||
|
|
||||||
toPath :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
toPath = flip force $ \case
|
|
||||||
NVStr p@(Text.uncons -> Just ('/', _)) _ ->
|
|
||||||
return $ NVLiteralPath (Text.unpack p)
|
|
||||||
v@(NVLiteralPath _) -> return v
|
|
||||||
v@(NVEnvPath _) -> return v
|
|
||||||
v -> throwError $ "builtins.toPath: expected string, got " ++ showValue v
|
|
||||||
|
|
||||||
pathExists_ :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
pathExists_ = flip force $ \case
|
|
||||||
NVLiteralPath p -> mkBool =<< pathExists p
|
|
||||||
NVEnvPath p -> mkBool =<< pathExists p
|
|
||||||
v -> throwError $ "builtins.pathExists: expected path, got " ++ showValue v
|
|
||||||
|
|
||||||
isAttrs :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
isAttrs = flip force $ \case
|
|
||||||
NVSet _ _ -> toValue True
|
|
||||||
_ -> toValue False
|
|
||||||
|
|
||||||
isList :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
isList = flip force $ \case
|
|
||||||
NVList _ -> toValue True
|
|
||||||
_ -> toValue False
|
|
||||||
|
|
||||||
isFunction :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
isFunction = flip force $ \case
|
|
||||||
NVClosure {} -> toValue True
|
|
||||||
_ -> toValue False
|
|
||||||
|
|
||||||
isString :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
isString = flip force $ \case
|
|
||||||
NVStr _ _ -> toValue True
|
|
||||||
_ -> toValue False
|
|
||||||
|
|
||||||
isInt :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
isInt = flip force $ \case
|
|
||||||
NVConstant (NInt _) -> toValue True
|
|
||||||
_ -> toValue False
|
|
||||||
|
|
||||||
isFloat :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
isFloat = flip force $ \case
|
|
||||||
NVConstant (NFloat _) -> toValue True
|
|
||||||
_ -> toValue False
|
|
||||||
|
|
||||||
isBool :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
isBool = flip force $ \case
|
|
||||||
NVConstant (NBool _) -> toValue True
|
|
||||||
_ -> toValue False
|
|
||||||
|
|
||||||
isNull :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
isNull = flip force $ \case
|
|
||||||
NVConstant NNull -> toValue True
|
|
||||||
_ -> toValue False
|
|
||||||
|
|
||||||
throw_ :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
throw_ = flip force $ \case
|
|
||||||
NVStr t _ -> throwError (Text.unpack t)
|
|
||||||
v -> throwError $ "builtins.throw: expected string, got " ++ showValue v
|
|
||||||
|
|
||||||
import_ :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
import_ = flip force $ \case
|
|
||||||
NVLiteralPath p -> importFile M.empty p
|
|
||||||
NVEnvPath p -> importFile M.empty p -- jww (2018-04-06): is this right?
|
|
||||||
v -> throwError $ "import: expected path, got " ++ showValue v
|
|
||||||
|
|
||||||
scopedImport :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
scopedImport aset path = force aset $ \aset' -> force path $ \path' ->
|
|
||||||
case (aset', path') of
|
|
||||||
(NVSet s _, NVLiteralPath p) -> importFile s p
|
|
||||||
(NVSet s _, NVEnvPath p) -> importFile s p
|
|
||||||
(s, p) -> throwError $ "scopedImport: expected a set and a path, got "
|
|
||||||
++ showValue s ++ " and " ++ showValue p
|
|
||||||
|
|
||||||
getEnv_ :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
getEnv_ = flip force $ \case
|
|
||||||
NVStr s _ -> do
|
|
||||||
mres <- getEnvVar (Text.unpack s)
|
|
||||||
return $ case mres of
|
|
||||||
Nothing -> NVStr "" mempty
|
|
||||||
Just v -> NVStr (Text.pack v) mempty
|
|
||||||
p -> error $ "Unexpected argument to getEnv: " ++ show (void p)
|
|
||||||
|
|
||||||
sort_ :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
sort_ comparator list = force list $ \case
|
|
||||||
NVList l -> NVList <$> sortByM cmp l
|
|
||||||
where
|
|
||||||
cmp a b = do
|
|
||||||
isLessThan <- comparator `apply` a `evalApp` b
|
|
||||||
fromValue isLessThan >>= \case
|
|
||||||
True -> pure LT
|
|
||||||
False -> do
|
|
||||||
isGreaterThan <- comparator `apply` b `evalApp` a
|
|
||||||
fromValue isGreaterThan >>= \case
|
|
||||||
True -> pure GT
|
|
||||||
False -> pure EQ
|
|
||||||
v -> throwError $ "builtins.sort: expected list, got " ++ showValue v
|
|
||||||
|
|
||||||
lessThan :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
lessThan ta tb = force ta $ \va -> force tb $ \vb -> do
|
|
||||||
let badType = throwError $ "builtins.lessThan: expected two numbers or two strings, "
|
|
||||||
++ "got " ++ showValue va ++ " and " ++ showValue vb
|
|
||||||
NVConstant . NBool <$> case (va, vb) of
|
|
||||||
(NVConstant ca, NVConstant cb) -> case (ca, cb) of
|
|
||||||
(NInt a, NInt b) -> pure $ a < b
|
|
||||||
(NFloat a, NInt b) -> pure $ a < fromInteger b
|
|
||||||
(NInt a, NFloat b) -> pure $ fromInteger a < b
|
|
||||||
(NFloat a, NFloat b) -> pure $ a < b
|
|
||||||
_ -> badType
|
|
||||||
(NVStr a _, NVStr b _) -> pure $ a < b
|
|
||||||
_ -> badType
|
|
||||||
|
|
||||||
concatLists :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
concatLists = flip force $ \case
|
|
||||||
NVList l -> fmap (NVList . concat) $ forM l $ flip force $ \case
|
|
||||||
NVList i -> pure i
|
|
||||||
v -> throwError $ "builtins.concatLists: expected list, got " ++ showValue v
|
|
||||||
v -> throwError $ "builtins.concatLists: expected list, got " ++ showValue v
|
|
||||||
|
|
||||||
listToAttrs :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
listToAttrs = flip force $ \case
|
|
||||||
NVList l -> fmap (flip NVSet M.empty . M.fromList . reverse) $
|
|
||||||
forM l $ flip force $ \case
|
|
||||||
NVSet s _ -> case (M.lookup "name" s, M.lookup "value" s) of
|
|
||||||
(Just name, Just value) -> force name $ \case
|
|
||||||
NVStr n _ -> return (n, value)
|
|
||||||
v -> throwError $
|
|
||||||
"builtins.listToAttrs: expected name to be a string, got "
|
|
||||||
++ showValue v
|
|
||||||
_ -> throwError $
|
|
||||||
"builtins.listToAttrs: expected set with name and value, got"
|
|
||||||
++ show s
|
|
||||||
v -> throwError $ "builtins.listToAttrs: expected set, got " ++ showValue v
|
|
||||||
v -> throwError $ "builtins.listToAttrs: expected list, got " ++ showValue v
|
|
||||||
|
|
||||||
hashString :: MonadBuiltins e m => Text -> Text -> Prim m Text
|
|
||||||
hashString algo s = Prim $ do
|
|
||||||
hash <- case algo of
|
|
||||||
"md5" -> pure MD5.hash
|
|
||||||
"sha1" -> pure SHA1.hash
|
|
||||||
"sha256" -> pure SHA256.hash
|
|
||||||
"sha512" -> pure SHA512.hash
|
|
||||||
_ -> throwError $ "builtins.hashString: "
|
|
||||||
++ "expected \"md5\", \"sha1\", \"sha256\", or \"sha512\", got " ++ show algo
|
|
||||||
pure $ decodeUtf8 $ Base16.encode $ hash $ encodeUtf8 s
|
|
||||||
|
|
||||||
absolutePathFromValue :: MonadBuiltins e m => NValue m -> m FilePath
|
|
||||||
absolutePathFromValue = \case
|
|
||||||
NVStr pathText _ -> do
|
|
||||||
let path = Text.unpack pathText
|
|
||||||
unless (isAbsolute path) $
|
|
||||||
throwError $ "string " ++ show path ++ " doesn't represent an absolute path"
|
|
||||||
pure path
|
|
||||||
NVLiteralPath path -> pure path
|
|
||||||
NVEnvPath path -> pure path
|
|
||||||
v -> throwError $ "expected a path, got " ++ showValue v
|
|
||||||
|
|
||||||
--TODO: Move all liftIO things into MonadNixEnv or similar
|
|
||||||
readFile_ :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
readFile_ pathThunk = do
|
|
||||||
path <- force pathThunk absolutePathFromValue
|
|
||||||
toValue =<< Nix.Stack.readFile path
|
|
||||||
|
|
||||||
data FileType
|
|
||||||
= FileType_Regular
|
|
||||||
| FileType_Directory
|
|
||||||
| FileType_Symlink
|
|
||||||
| FileType_Unknown
|
|
||||||
deriving (Show, Read, Eq, Ord)
|
|
||||||
|
|
||||||
instance ToNix FileType where
|
|
||||||
toValue = toValue . \case
|
|
||||||
FileType_Regular -> "regular" :: Text
|
|
||||||
FileType_Directory -> "directory"
|
|
||||||
FileType_Symlink -> "symlink"
|
|
||||||
FileType_Unknown -> "unknown"
|
|
||||||
|
|
||||||
readDir_ :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
readDir_ pathThunk = do
|
|
||||||
path <- force pathThunk absolutePathFromValue
|
|
||||||
items <- listDirectory path
|
|
||||||
itemsWithTypes <- forM items $ \item -> do
|
|
||||||
s <- Nix.Monad.getSymbolicLinkStatus $ path </> item
|
|
||||||
let t = if
|
|
||||||
| isRegularFile s -> FileType_Regular
|
|
||||||
| isDirectory s -> FileType_Directory
|
|
||||||
| isSymbolicLink s -> FileType_Symlink
|
|
||||||
| otherwise -> FileType_Unknown
|
|
||||||
pure (Text.pack item, t)
|
|
||||||
toValue $ M.fromList itemsWithTypes
|
|
||||||
|
|
||||||
fromJSON :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
fromJSON t = fromThunk t $ \encoded ->
|
|
||||||
case A.eitherDecodeStrict' @A.Value $ encodeUtf8 encoded of
|
|
||||||
Left jsonError -> throwError $ "builtins.fromJSON: " ++ jsonError
|
|
||||||
Right v -> toValue v
|
|
||||||
|
|
||||||
toXML_ :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
toXML_ = flip force $ normalForm >=> \x ->
|
|
||||||
pure $ NVStr (Text.pack (toXML x)) mempty
|
|
||||||
|
|
||||||
typeOf :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
|
||||||
typeOf t = force t $ \v -> toValue @Text $ case v of
|
|
||||||
NVConstant a -> case a of
|
|
||||||
NInt _ -> "int"
|
|
||||||
NFloat _ -> "float"
|
|
||||||
NBool _ -> "bool"
|
|
||||||
NNull -> "null"
|
|
||||||
NUri _ -> "string" --TODO: Should we get rid of NUri?
|
|
||||||
NVStr _ _ -> "string"
|
|
||||||
NVList _ -> "list"
|
|
||||||
NVSet _ _ -> "set"
|
|
||||||
NVClosure {} -> "lambda"
|
|
||||||
NVLiteralPath _ -> "path"
|
|
||||||
NVEnvPath _ -> "path"
|
|
||||||
NVBuiltin _ _ -> "lambda"
|
|
||||||
|
|
||||||
partition_ :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
|
|
||||||
partition_ f = flip force $ \case
|
|
||||||
NVList l -> do
|
|
||||||
let match t = apply f t >>= \case
|
|
||||||
NVConstant (NBool b) -> return (b, t)
|
|
||||||
v -> error $ "partition: Expected boolean, got " ++ showValue v
|
|
||||||
selection <- traverse match l
|
|
||||||
let (right, wrong) = partition fst selection
|
|
||||||
let makeSide = valueThunk . NVList . map snd
|
|
||||||
return $ flip NVSet M.empty $
|
|
||||||
M.fromList [("right", makeSide right), ("wrong", makeSide wrong)]
|
|
||||||
v -> error $ "partition: Expected list, got " ++ showValue v
|
|
||||||
|
|
||||||
currentSystem :: MonadNix m => m (NValue m)
|
|
||||||
currentSystem = do
|
|
||||||
os <- getCurrentSystemOS
|
|
||||||
arch <- getCurrentSystemArch
|
|
||||||
return $ NVStr (os <> "-" <> arch) mempty
|
|
||||||
|
|
||||||
newtype Prim m a = Prim { runPrim :: m a }
|
|
||||||
|
|
||||||
class ToNix a where
|
|
||||||
toValue :: MonadBuiltins e m => a -> m (NValue m)
|
|
||||||
|
|
||||||
instance ToNix Bool where
|
|
||||||
toValue = return . NVConstant . NBool
|
|
||||||
|
|
||||||
instance ToNix Text where
|
|
||||||
toValue s = return $ NVStr s mempty
|
|
||||||
|
|
||||||
instance ToNix ByteString where
|
|
||||||
toValue s = return $ NVStr (decodeUtf8 s) mempty
|
|
||||||
|
|
||||||
instance ToNix Int where
|
|
||||||
toValue = toValue . toInteger
|
|
||||||
|
|
||||||
instance ToNix Integer where
|
|
||||||
toValue = return . NVConstant . NInt
|
|
||||||
|
|
||||||
instance ToNix a => ToNix (HashMap Text a) where
|
|
||||||
toValue m = flip NVSet M.empty <$> traverse (thunk . toValue) m
|
|
||||||
|
|
||||||
instance ToNix a => ToNix [a] where
|
|
||||||
toValue m = NVList <$> traverse (thunk . toValue) m
|
|
||||||
|
|
||||||
instance ToNix A.Value where
|
|
||||||
toValue = \case
|
|
||||||
A.Object m -> flip NVSet M.empty <$> traverse (thunk . toValue) m
|
|
||||||
A.Array l -> NVList <$> traverse (thunk . toValue) (V.toList l)
|
|
||||||
A.String s -> pure $ NVStr s mempty
|
|
||||||
A.Number n -> pure $ NVConstant $ case floatingOrInteger n of
|
|
||||||
Left r -> NFloat r
|
|
||||||
Right i -> NInt i
|
|
||||||
A.Bool b -> pure $ NVConstant $ NBool b
|
|
||||||
A.Null -> pure $ NVConstant NNull
|
|
||||||
|
|
||||||
-- | Types that support conversion to nix in a particular monad
|
|
||||||
class ToBuiltin m a | a -> m where
|
|
||||||
toBuiltin :: String -> a -> m (NValue m)
|
|
||||||
|
|
||||||
instance (MonadBuiltins e m, ToNix a) => ToBuiltin m (Prim m a) where
|
|
||||||
toBuiltin _ p = toValue =<< runPrim p
|
|
||||||
|
|
||||||
instance (MonadBuiltins e m, FromNix a, ToBuiltin m b)
|
|
||||||
=> ToBuiltin m (a -> b) where
|
|
||||||
toBuiltin name f =
|
|
||||||
return $ NVBuiltin name $ fromThunk ?? (toBuiltin name . f)
|
|
||||||
|
|
||||||
class FromNix a where
|
|
||||||
--TODO: Get rid of the HasCallStack - it should be captured by whatever
|
|
||||||
--error reporting mechanism we add
|
|
||||||
fromValue :: (HasCallStack, MonadBuiltins e m) => NValue m -> m a
|
|
||||||
|
|
||||||
fromThunk :: (FromNix a, HasCallStack, MonadBuiltins e m)
|
|
||||||
=> NThunk m -> (a -> m r) -> m r
|
|
||||||
fromThunk t f = force t (f <=< fromValue)
|
|
||||||
|
|
||||||
instance FromNix Bool where
|
|
||||||
fromValue = \case
|
|
||||||
NVConstant (NBool b) -> pure b
|
|
||||||
v -> throwError $ "fromValue: Expected bool, got " ++ showValue v
|
|
||||||
|
|
||||||
instance FromNix Text where
|
|
||||||
fromValue = \case
|
|
||||||
NVStr s _ -> pure s
|
|
||||||
v -> throwError $ "fromValue: Expected string, got " ++ showValue v
|
|
||||||
|
|
||||||
instance FromNix Int where
|
|
||||||
fromValue = fmap fromInteger . fromValue
|
|
||||||
|
|
||||||
instance FromNix Integer where
|
|
||||||
fromValue = \case
|
|
||||||
NVConstant (NInt n) -> pure n
|
|
||||||
v -> throwError $ "fromValue: Expected number, got " ++ showValue v
|
|
||||||
|
|
||||||
instance FromNix a => FromNix [a] where
|
|
||||||
fromValue = \case
|
|
||||||
NVList l -> traverse (`force` fromValue) l
|
|
||||||
v -> throwError $ "fromValue: Expected list, got " ++ showValue v
|
|
||||||
|
|
||||||
toEncodingSorted :: A.Value -> A.Encoding
|
|
||||||
toEncodingSorted = \case
|
|
||||||
A.Object m -> A.pairs $ mconcat $ fmap (\(k, v) -> A.pair k $ toEncodingSorted v) $ sortOn fst $ M.toList m
|
|
||||||
A.Array l -> A.list toEncodingSorted $ V.toList l
|
|
||||||
v -> A.toEncoding v
|
|
||||||
|
|
||||||
instance FromNix A.Value where
|
|
||||||
fromValue = \case
|
|
||||||
NVConstant a -> pure $ case a of
|
|
||||||
NInt n -> toJSON n
|
|
||||||
NFloat n -> toJSON n
|
|
||||||
NBool b -> toJSON b
|
|
||||||
NNull -> A.Null
|
|
||||||
NUri u -> toJSON u
|
|
||||||
NVStr s _ -> pure $ toJSON s
|
|
||||||
NVList l -> A.Array . V.fromList <$> traverse (`force` fromValue) l
|
|
||||||
NVSet m _ -> A.Object <$> traverse (`force` fromValue) m
|
|
||||||
NVClosure {} -> throwError "cannot convert a function to JSON"
|
|
||||||
NVLiteralPath p -> toJSON . unStorePath <$> addPath p
|
|
||||||
NVEnvPath p -> toJSON . unStorePath <$> addPath p
|
|
||||||
NVBuiltin _ _ -> throwError "cannot convert a built-in function to JSON"
|
|
680
Nix/Eval.hs
680
Nix/Eval.hs
|
@ -1,680 +0,0 @@
|
||||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
|
||||||
{-# LANGUAGE ApplicativeDo #-}
|
|
||||||
{-# LANGUAGE ConstraintKinds #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE FunctionalDependencies #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE MultiWayIf #-}
|
|
||||||
{-# LANGUAGE PartialTypeSignatures #-}
|
|
||||||
{-# LANGUAGE RankNTypes #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
|
|
||||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
|
||||||
|
|
||||||
module Nix.Eval where
|
|
||||||
|
|
||||||
import Control.Applicative
|
|
||||||
import Control.Arrow (first)
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.Fix
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Control.Monad.Trans.Class
|
|
||||||
import Control.Monad.Trans.Except
|
|
||||||
import Control.Monad.Trans.Reader
|
|
||||||
import Data.Align
|
|
||||||
import Data.Align.Key
|
|
||||||
import Data.Coerce
|
|
||||||
import Data.Fix
|
|
||||||
import Data.Functor.Compose
|
|
||||||
import Data.HashMap.Lazy (HashMap)
|
|
||||||
import qualified Data.HashMap.Lazy as M
|
|
||||||
import Data.HashMap.Strict.InsOrd (toHashMap)
|
|
||||||
import Data.List (intercalate, partition, foldl')
|
|
||||||
import Data.Maybe (fromMaybe, catMaybes)
|
|
||||||
import Data.Text (Text)
|
|
||||||
import qualified Data.Text as Text
|
|
||||||
import Data.These
|
|
||||||
import Data.Traversable (for)
|
|
||||||
import Nix.Atoms
|
|
||||||
import Nix.Expr
|
|
||||||
import Nix.Monad
|
|
||||||
import Nix.Pretty
|
|
||||||
import Nix.Scope
|
|
||||||
import Nix.Stack
|
|
||||||
import Nix.StringOperations (runAntiquoted)
|
|
||||||
import Nix.Thunk
|
|
||||||
import Nix.Utils
|
|
||||||
import Nix.Value
|
|
||||||
|
|
||||||
type MonadEval e m =
|
|
||||||
( Scoped e (NThunk m) m
|
|
||||||
, Framed e m
|
|
||||||
, MonadExpr (NThunk m) (NValue m) m
|
|
||||||
, MonadVar m
|
|
||||||
, MonadFile m
|
|
||||||
)
|
|
||||||
|
|
||||||
-- | Evaluate an nix expression, with a given ValueSet as environment
|
|
||||||
evalExpr :: (MonadEval e m, MonadFix m, MonadNix m) => NExpr -> m (NValue m)
|
|
||||||
evalExpr = cata eval
|
|
||||||
|
|
||||||
eval :: forall e m. (MonadEval e m, MonadFix m, MonadNix m)
|
|
||||||
=> NExprF (m (NValue m)) -> m (NValue m)
|
|
||||||
|
|
||||||
eval (NSym var) = do
|
|
||||||
traceM $ "NSym: var = " ++ show var
|
|
||||||
mres <- lookupVar var
|
|
||||||
case mres of
|
|
||||||
Nothing ->
|
|
||||||
throwError $ "Undefined variable '" ++ Text.unpack var ++ "'"
|
|
||||||
Just v -> force v pure
|
|
||||||
|
|
||||||
eval (NConstant x) = return $ NVConstant x
|
|
||||||
eval (NStr str) = traceM "NStr" >> evalString str
|
|
||||||
eval (NLiteralPath p) =
|
|
||||||
traceM "NLiteralPath" >> NVLiteralPath <$> makeAbsolutePath p
|
|
||||||
eval (NEnvPath p) = return $ NVEnvPath p
|
|
||||||
|
|
||||||
eval (NUnary op arg) = do
|
|
||||||
traceM "NUnary"
|
|
||||||
arg >>= \case
|
|
||||||
NVConstant c -> case (op, c) of
|
|
||||||
(NNeg, NInt i) -> return $ NVConstant $ NInt (-i)
|
|
||||||
(NNeg, NFloat f) -> return $ NVConstant $ NFloat (-f)
|
|
||||||
(NNot, NBool b) -> return $ NVConstant $ NBool (not b)
|
|
||||||
_ -> throwError $ "unsupported argument type for unary operator "
|
|
||||||
++ show op
|
|
||||||
x -> throwError $ "argument to unary operator"
|
|
||||||
++ " must evaluate to an atomic type: " ++ showValue x
|
|
||||||
|
|
||||||
eval (NBinary op larg rarg) = case op of
|
|
||||||
NOr -> larg >>= \case
|
|
||||||
NVConstant (NBool l) -> if l
|
|
||||||
then valueRefBool True
|
|
||||||
else rarg >>= \case
|
|
||||||
NVConstant (NBool r) -> valueRefBool r
|
|
||||||
v -> throwError $ "operator `||`: left argument: boolean expected, got " ++ show (void v)
|
|
||||||
v -> throwError $ "operator `||`: right argument: boolean expected, got " ++ show (void v)
|
|
||||||
NAnd -> larg >>= \case
|
|
||||||
NVConstant (NBool l) -> if l
|
|
||||||
then rarg >>= \case
|
|
||||||
NVConstant (NBool r) -> valueRefBool r
|
|
||||||
v -> throwError $ "operator `&&`: left argument: boolean expected, got " ++ show (void v)
|
|
||||||
else valueRefBool False
|
|
||||||
v -> throwError $ "operator `&&`: right argument: boolean expected, got " ++ show (void v)
|
|
||||||
-- TODO: Refactor so that eval (NBinary ..) *always* dispatches based on
|
|
||||||
-- operator first
|
|
||||||
_ -> do
|
|
||||||
lval <- traceM "NBinary:left" >> larg
|
|
||||||
rval <- traceM "NBinary:right" >> rarg
|
|
||||||
let unsupportedTypes =
|
|
||||||
"unsupported argument types for binary operator "
|
|
||||||
++ showValue lval ++ " " ++ show op ++ " " ++ showValue rval
|
|
||||||
numBinOp :: (forall a. Num a => a -> a -> a) -> NAtom -> NAtom
|
|
||||||
-> m (NValue m)
|
|
||||||
numBinOp f = numBinOp' f f
|
|
||||||
numBinOp'
|
|
||||||
:: (Integer -> Integer -> Integer)
|
|
||||||
-> (Float -> Float -> Float)
|
|
||||||
-> NAtom -> NAtom -> m (NValue m)
|
|
||||||
numBinOp' intF floatF l r = case (l, r) of
|
|
||||||
(NInt li, NInt ri) ->
|
|
||||||
valueRefInt $ li `intF` ri
|
|
||||||
(NInt li, NFloat rf) ->
|
|
||||||
valueRefFloat $ fromInteger li `floatF` rf
|
|
||||||
(NFloat lf, NInt ri) ->
|
|
||||||
valueRefFloat $ lf `floatF` fromInteger ri
|
|
||||||
(NFloat lf, NFloat rf) ->
|
|
||||||
valueRefFloat $ lf `floatF` rf
|
|
||||||
_ -> throwError unsupportedTypes
|
|
||||||
case (lval, rval) of
|
|
||||||
(NVConstant lc, NVConstant rc) -> case (op, lc, rc) of
|
|
||||||
(NEq, _, _) -> valueRefBool =<< valueEq lval rval
|
|
||||||
(NNEq, _, _) -> valueRefBool . not =<< valueEq lval rval
|
|
||||||
(NLt, l, r) -> valueRefBool $ l < r
|
|
||||||
(NLte, l, r) -> valueRefBool $ l <= r
|
|
||||||
(NGt, l, r) -> valueRefBool $ l > r
|
|
||||||
(NGte, l, r) -> valueRefBool $ l >= r
|
|
||||||
(NAnd, _, _) -> error "should be impossible: && is handled above"
|
|
||||||
(NOr, _, _) -> error "should be impossible: || is handled above"
|
|
||||||
(NImpl, NBool l, NBool r) -> valueRefBool $ not l || r
|
|
||||||
(NPlus, l, r) -> numBinOp (+) l r
|
|
||||||
(NMinus, l, r) -> numBinOp (-) l r
|
|
||||||
(NMult, l, r) -> numBinOp (*) l r
|
|
||||||
(NDiv, l, r) -> numBinOp' div (/) l r
|
|
||||||
_ -> throwError unsupportedTypes
|
|
||||||
|
|
||||||
(NVStr ls lc, NVStr rs rc) -> case op of
|
|
||||||
NPlus -> return $ NVStr (ls `mappend` rs) (lc `mappend` rc)
|
|
||||||
NEq -> valueRefBool =<< valueEq lval rval
|
|
||||||
NNEq -> valueRefBool . not =<< valueEq lval rval
|
|
||||||
NLt -> valueRefBool $ ls < rs
|
|
||||||
NLte -> valueRefBool $ ls <= rs
|
|
||||||
NGt -> valueRefBool $ ls > rs
|
|
||||||
NGte -> valueRefBool $ ls >= rs
|
|
||||||
_ -> throwError unsupportedTypes
|
|
||||||
|
|
||||||
(NVStr _ _, NVConstant NNull) -> case op of
|
|
||||||
NEq -> valueRefBool =<< valueEq lval (NVStr "" mempty)
|
|
||||||
NNEq -> valueRefBool . not =<< valueEq lval (NVStr "" mempty)
|
|
||||||
_ -> throwError unsupportedTypes
|
|
||||||
|
|
||||||
(NVConstant NNull, NVStr _ _) -> case op of
|
|
||||||
NEq -> valueRefBool =<< valueEq (NVStr "" mempty) rval
|
|
||||||
NNEq -> valueRefBool . not =<< valueEq (NVStr "" mempty) rval
|
|
||||||
_ -> throwError unsupportedTypes
|
|
||||||
|
|
||||||
(NVSet ls lp, NVSet rs rp) -> case op of
|
|
||||||
NUpdate -> return $ NVSet (rs `M.union` ls) (rp `M.union` lp)
|
|
||||||
NEq -> valueRefBool =<< valueEq lval rval
|
|
||||||
NNEq -> valueRefBool . not =<< valueEq lval rval
|
|
||||||
_ -> throwError unsupportedTypes
|
|
||||||
|
|
||||||
(NVList ls, NVList rs) -> case op of
|
|
||||||
NConcat -> return $ NVList $ ls ++ rs
|
|
||||||
NEq -> valueRefBool =<< valueEq lval rval
|
|
||||||
NNEq -> valueRefBool . not =<< valueEq lval rval
|
|
||||||
_ -> throwError unsupportedTypes
|
|
||||||
|
|
||||||
(NVList ls, NVConstant NNull) -> case op of
|
|
||||||
NConcat -> return $ NVList ls
|
|
||||||
NEq -> valueRefBool =<< valueEq lval (NVList [])
|
|
||||||
NNEq -> valueRefBool . not =<< valueEq lval (NVList [])
|
|
||||||
_ -> throwError unsupportedTypes
|
|
||||||
|
|
||||||
(NVConstant NNull, NVList rs) -> case op of
|
|
||||||
NConcat -> return $ NVList rs
|
|
||||||
NEq -> valueRefBool =<< valueEq (NVList []) rval
|
|
||||||
NNEq -> valueRefBool . not =<< valueEq (NVList []) rval
|
|
||||||
_ -> throwError unsupportedTypes
|
|
||||||
|
|
||||||
(NVLiteralPath ls, NVLiteralPath rs) -> case op of
|
|
||||||
-- TODO: Canonicalise path
|
|
||||||
NPlus -> NVLiteralPath <$> makeAbsolutePath (ls ++ rs)
|
|
||||||
_ -> throwError unsupportedTypes
|
|
||||||
|
|
||||||
(NVLiteralPath ls, NVStr rs _) -> case op of
|
|
||||||
-- TODO: Canonicalise path
|
|
||||||
NPlus -> NVLiteralPath
|
|
||||||
<$> makeAbsolutePath (ls `mappend` Text.unpack rs)
|
|
||||||
_ -> throwError unsupportedTypes
|
|
||||||
|
|
||||||
_ -> throwError unsupportedTypes
|
|
||||||
|
|
||||||
eval (NSelect aset attr alternative) = do
|
|
||||||
traceM "NSelect"
|
|
||||||
mres <- evalSelect aset attr
|
|
||||||
case mres of
|
|
||||||
Right v -> do
|
|
||||||
traceM $ "Wrapping a selector: " ++ show (void v)
|
|
||||||
pure v
|
|
||||||
Left (s, ks) -> fromMaybe err alternative
|
|
||||||
where
|
|
||||||
err = throwError $ "could not look up attribute "
|
|
||||||
++ intercalate "." (map Text.unpack ks)
|
|
||||||
++ " in " ++ showValue s
|
|
||||||
|
|
||||||
eval (NHasAttr aset attr) = do
|
|
||||||
traceM "NHasAttr"
|
|
||||||
NVConstant . NBool . either (const False) (const True)
|
|
||||||
<$> evalSelect aset attr
|
|
||||||
|
|
||||||
eval (NList l) = do
|
|
||||||
traceM "NList"
|
|
||||||
scope <- currentScopes
|
|
||||||
NVList <$> for l (thunk . withScopes @(NThunk m) scope)
|
|
||||||
|
|
||||||
eval (NSet binds) = do
|
|
||||||
traceM "NSet..1"
|
|
||||||
(s, p) <- evalBinds True False binds
|
|
||||||
traceM $ "NSet..2: s = " ++ show (void s)
|
|
||||||
traceM $ "NSet..2: p = " ++ show (void p)
|
|
||||||
return $ NVSet s p
|
|
||||||
|
|
||||||
eval (NRecSet binds) = do
|
|
||||||
traceM "NRecSet..1"
|
|
||||||
(s, p) <- evalBinds True True binds
|
|
||||||
traceM $ "NRecSet..2: s = " ++ show (void s)
|
|
||||||
traceM $ "NRecSet..2: p = " ++ show (void p)
|
|
||||||
return $ NVSet s p
|
|
||||||
|
|
||||||
eval (NLet binds e) = do
|
|
||||||
traceM "Let..1"
|
|
||||||
(s, _) <- evalBinds True True binds
|
|
||||||
traceM $ "Let..2: s = " ++ show (void s)
|
|
||||||
pushScope s e
|
|
||||||
|
|
||||||
eval (NIf cond t f) = do
|
|
||||||
traceM "NIf"
|
|
||||||
cond >>= \case
|
|
||||||
NVConstant (NBool True) -> t
|
|
||||||
NVConstant (NBool False) -> f
|
|
||||||
x -> throwError $ "condition must be a boolean: "++ showValue x
|
|
||||||
|
|
||||||
eval (NWith scope body) = do
|
|
||||||
traceM "NWith"
|
|
||||||
s <- thunk scope
|
|
||||||
pushWeakScope ?? body $ force s $ \case
|
|
||||||
NVSet s _ -> return s
|
|
||||||
x -> throwError $ "scope must be a set in with statement, but saw: "
|
|
||||||
++ showValue x
|
|
||||||
|
|
||||||
eval (NAssert cond body) = do
|
|
||||||
traceM "NAssert"
|
|
||||||
cond >>= \case
|
|
||||||
NVConstant (NBool True) -> body
|
|
||||||
NVConstant (NBool False) -> throwError "assertion failed"
|
|
||||||
x -> throwError $ "assertion condition must be boolean, but saw: "
|
|
||||||
++ showValue x
|
|
||||||
|
|
||||||
eval (NApp fun arg) = do
|
|
||||||
traceM "NApp"
|
|
||||||
evalApp fun =<< thunk arg
|
|
||||||
|
|
||||||
eval (NAbs params body) = do
|
|
||||||
traceM "NAbs"
|
|
||||||
-- It is the environment at the definition site, not the call site, that
|
|
||||||
-- needs to be used when evaluating the body and default arguments, hence
|
|
||||||
-- we defer here so the present scope is restored when the parameters and
|
|
||||||
-- body are forced during application.
|
|
||||||
scope <- currentScopes @_ @(NThunk m)
|
|
||||||
traceM $ "Creating lambda abstraction in scope: " ++ show scope
|
|
||||||
return $ NVClosure scope (thunk <$> params) (thunk body)
|
|
||||||
|
|
||||||
infixl 1 `evalApp`
|
|
||||||
evalApp :: forall e m. (MonadEval e m, MonadFix m)
|
|
||||||
=> m (NValue m) -> NThunk m -> m (NValue m)
|
|
||||||
evalApp fun arg = fun >>= \case
|
|
||||||
NVClosure scope params f -> do
|
|
||||||
traceM "evalApp:NVFunction"
|
|
||||||
env <- currentScopes @_ @(NThunk m)
|
|
||||||
args <- buildArgument params =<< thunk (withScopes env (force arg pure))
|
|
||||||
traceM $ "Evaluating function application with args: "
|
|
||||||
++ show (newScope args)
|
|
||||||
withScopes @(NThunk m) scope $ pushScope args $
|
|
||||||
force ?? pure =<< f
|
|
||||||
NVBuiltin name f -> do
|
|
||||||
traceM $ "evalApp:NVBuiltin " ++ name
|
|
||||||
env <- currentScopes @_ @(NThunk m)
|
|
||||||
f =<< thunk (withScopes env (force arg pure))
|
|
||||||
s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do
|
|
||||||
traceM "evalApp:__functor"
|
|
||||||
force f $ \f' -> pure f' `evalApp` valueThunk s `evalApp` arg
|
|
||||||
x -> throwError $ "Attempt to call non-function: " ++ showValue x
|
|
||||||
|
|
||||||
-----
|
|
||||||
|
|
||||||
valueRefBool :: MonadNix m => Bool -> m (NValue m)
|
|
||||||
valueRefBool = return . NVConstant . NBool
|
|
||||||
|
|
||||||
valueRefInt :: MonadNix m => Integer -> m (NValue m)
|
|
||||||
valueRefInt = return . NVConstant . NInt
|
|
||||||
|
|
||||||
valueRefFloat :: MonadNix m => Float -> m (NValue m)
|
|
||||||
valueRefFloat = return . NVConstant . NFloat
|
|
||||||
|
|
||||||
thunkEq :: (MonadNix m, Framed e m, MonadFile m, MonadVar m)
|
|
||||||
=> NThunk m -> NThunk m -> m Bool
|
|
||||||
thunkEq lt rt = force lt $ \lv -> force rt $ \rv -> valueEq lv rv
|
|
||||||
|
|
||||||
-- | Checks whether two containers are equal, using the given item equality
|
|
||||||
-- predicate. If there are any item slots that don't match between the two
|
|
||||||
-- containers, the result will be False.
|
|
||||||
alignEqM
|
|
||||||
:: (Align f, Traversable f, Monad m)
|
|
||||||
=> (a -> b -> m Bool)
|
|
||||||
-> f a
|
|
||||||
-> f b
|
|
||||||
-> m Bool
|
|
||||||
alignEqM eq fa fb = fmap (either (const False) (const True)) $ runExceptT $ do
|
|
||||||
pairs <- forM (align fa fb) $ \case
|
|
||||||
These a b -> return (a, b)
|
|
||||||
_ -> throwE ()
|
|
||||||
forM_ pairs $ \(a, b) -> guard =<< lift (eq a b)
|
|
||||||
|
|
||||||
valueEq :: (MonadNix m, Framed e m, MonadFile m, MonadVar m)
|
|
||||||
=> NValue m -> NValue m -> m Bool
|
|
||||||
valueEq l r = case (l, r) of
|
|
||||||
(NVStr ls _, NVConstant (NUri ru)) -> pure $ ls == ru
|
|
||||||
(NVConstant (NUri lu), NVStr rs _) -> pure $ lu == rs
|
|
||||||
(NVConstant lc, NVConstant rc) -> pure $ lc == rc
|
|
||||||
(NVStr ls _, NVStr rs _) -> pure $ ls == rs
|
|
||||||
(NVStr ls _, NVConstant NNull) -> pure $ ls == ""
|
|
||||||
(NVConstant NNull, NVStr rs _) -> pure $ "" == rs
|
|
||||||
(NVList ls, NVList rs) -> alignEqM thunkEq ls rs
|
|
||||||
(NVSet lm _, NVSet rm _) -> alignEqM thunkEq lm rm
|
|
||||||
(NVLiteralPath lp, NVLiteralPath rp) -> pure $ lp == rp
|
|
||||||
(NVEnvPath lp, NVEnvPath rp) -> pure $ lp == rp
|
|
||||||
_ -> pure False
|
|
||||||
|
|
||||||
-----
|
|
||||||
|
|
||||||
normalFormBy :: forall e m. MonadEval e m
|
|
||||||
=> (forall r. NThunk m -> (NValue m -> m r) -> m r)
|
|
||||||
-> NValue m
|
|
||||||
-> m (NValueNF m)
|
|
||||||
normalFormBy k = \case
|
|
||||||
NVConstant a -> return $ Fix $ NVConstant a
|
|
||||||
NVStr t s -> return $ Fix $ NVStr t s
|
|
||||||
NVList l ->
|
|
||||||
Fix . NVList <$> traverse (`k` normalFormBy k) l
|
|
||||||
NVSet s p ->
|
|
||||||
Fix . flip NVSet p <$> traverse (`k` normalFormBy k) s
|
|
||||||
NVClosure s p f -> withScopes @(NThunk m) s $ do
|
|
||||||
p' <- traverse (fmap (`k` normalFormBy k)) p
|
|
||||||
return $ Fix $
|
|
||||||
NVClosure emptyScopes p' ((`k` normalFormBy k) =<< f)
|
|
||||||
NVLiteralPath fp -> return $ Fix $ NVLiteralPath fp
|
|
||||||
NVEnvPath p -> return $ Fix $ NVEnvPath p
|
|
||||||
NVBuiltin name f -> return $ Fix $ NVBuiltin name f
|
|
||||||
|
|
||||||
normalForm :: forall e m. MonadEval e m => NValue m -> m (NValueNF m)
|
|
||||||
normalForm = normalFormBy force
|
|
||||||
|
|
||||||
valueText :: forall e m. (MonadEval e m, MonadNix m)
|
|
||||||
=> Bool -> NValueNF m -> m (Text, DList Text)
|
|
||||||
valueText addPathsToStore = cata phi where
|
|
||||||
phi :: NValueF m (m (Text, DList Text)) -> m (Text, DList Text)
|
|
||||||
phi (NVConstant a) = pure (atomText a, mempty)
|
|
||||||
phi (NVStr t c) = pure (t, c)
|
|
||||||
phi (NVList _) = throwError "Cannot coerce a list to a string"
|
|
||||||
phi (NVSet set _)
|
|
||||||
| Just asString <-
|
|
||||||
-- TODO: Should this be run through valueText recursively?
|
|
||||||
M.lookup "__asString" set = asString
|
|
||||||
| otherwise = throwError "Cannot coerce a set to a string"
|
|
||||||
phi NVClosure {} = throwError "Cannot coerce a function to a string"
|
|
||||||
phi (NVLiteralPath originalPath)
|
|
||||||
| addPathsToStore = do
|
|
||||||
-- TODO: Capture and use the path of the file being processed as the
|
|
||||||
-- base path
|
|
||||||
storePath <- addPath originalPath
|
|
||||||
pure (Text.pack $ unStorePath storePath, mempty)
|
|
||||||
| otherwise = pure (Text.pack originalPath, mempty)
|
|
||||||
phi (NVEnvPath p) =
|
|
||||||
-- TODO: Ensure this is a store path
|
|
||||||
pure (Text.pack p, mempty)
|
|
||||||
phi (NVBuiltin _ _) = throwError "Cannot coerce a function to a string"
|
|
||||||
|
|
||||||
valueTextNoContext :: (MonadEval e m, MonadNix m)
|
|
||||||
=> Bool -> NValueNF m -> m Text
|
|
||||||
valueTextNoContext addPathsToStore = fmap fst . valueText addPathsToStore
|
|
||||||
|
|
||||||
----
|
|
||||||
|
|
||||||
-- | The following functions are generalized so that they can be used by other
|
|
||||||
-- evaluators which do not differ in the core aspects of the lambda calculus
|
|
||||||
-- that Nix represents.
|
|
||||||
--
|
|
||||||
-- jww (2018-04-02): This "subset" of the language should be called out more
|
|
||||||
-- directly, as a separate data type, to avoid abstracting it in this ad hoc
|
|
||||||
-- way.
|
|
||||||
|
|
||||||
class (Monoid (MText m), Coercible (Thunk m v) t)
|
|
||||||
=> MonadExpr t v m | m -> t, m -> v where
|
|
||||||
embedSet :: HashMap Text t -> m v
|
|
||||||
projectSet :: v -> m (Maybe (HashMap Text t))
|
|
||||||
projectSetWithPos :: v -> m (Maybe (HashMap Text t, HashMap Text Delta))
|
|
||||||
|
|
||||||
type MText m :: *
|
|
||||||
|
|
||||||
wrapText :: Text -> m (MText m)
|
|
||||||
unwrapText :: MText m -> m Text
|
|
||||||
|
|
||||||
embedText :: MText m -> m v
|
|
||||||
projectText :: v -> m (Maybe (Maybe (MText m)))
|
|
||||||
|
|
||||||
buildArgument
|
|
||||||
:: forall e t v m. (MonadExpr t v m, Scoped e t m, Framed e m,
|
|
||||||
MonadVar m, MonadFix m, MonadFile m)
|
|
||||||
=> Params (m t) -> t -> m (HashMap Text t)
|
|
||||||
buildArgument params arg = case params of
|
|
||||||
Param name -> return $ M.singleton name arg
|
|
||||||
ParamSet s isVariadic m ->
|
|
||||||
forceThunk (coerce arg) $ projectSet @t @v @m >=> \case
|
|
||||||
Just args -> do
|
|
||||||
let inject = case m of
|
|
||||||
Nothing -> id
|
|
||||||
Just n -> M.insert n $ const $ pure arg
|
|
||||||
loebM (inject $ alignWithKey (assemble isVariadic) args (toHashMap s))
|
|
||||||
|
|
||||||
x -> throwError $ "Expected set in function call, received: "
|
|
||||||
++ show (void x)
|
|
||||||
where
|
|
||||||
assemble :: Bool
|
|
||||||
-> Text
|
|
||||||
-> These t (Maybe (m t))
|
|
||||||
-> HashMap Text t
|
|
||||||
-> m t
|
|
||||||
assemble isVariadic k = \case
|
|
||||||
That Nothing ->
|
|
||||||
const $ throwError $ "Missing value for parameter: " ++ show k
|
|
||||||
That (Just f) -> \args -> do
|
|
||||||
scope <- currentScopes @_ @t
|
|
||||||
traceM $ "Deferring default argument in scope: " ++ show scope
|
|
||||||
fmap (coerce @(Thunk m v) @t) $ buildThunk $ clearScopes @t $ do
|
|
||||||
traceM $ "Evaluating default argument with args: "
|
|
||||||
++ show (newScope args)
|
|
||||||
pushScopes scope $ pushScope args $
|
|
||||||
(\x -> forceThunk (coerce x) pure) =<< f
|
|
||||||
This x | isVariadic -> const (pure x)
|
|
||||||
| otherwise ->
|
|
||||||
const $ throwError $ "Unexpected parameter: " ++ show k
|
|
||||||
These x _ -> const (pure x)
|
|
||||||
|
|
||||||
attrSetAlter
|
|
||||||
:: forall e t v m. (MonadExpr t v m, Scoped e t m, Framed e m,
|
|
||||||
MonadVar m, MonadFile m)
|
|
||||||
=> [Text]
|
|
||||||
-> HashMap Text (m v)
|
|
||||||
-> m v
|
|
||||||
-> m (HashMap Text (m v))
|
|
||||||
attrSetAlter [] _ _ = throwError "invalid selector with no components"
|
|
||||||
attrSetAlter (p:ps) m val = case M.lookup p m of
|
|
||||||
Nothing
|
|
||||||
| null ps -> go
|
|
||||||
| otherwise -> recurse M.empty
|
|
||||||
Just v
|
|
||||||
| null ps -> go
|
|
||||||
| otherwise -> v >>= projectSet @t @v @m >>= \case
|
|
||||||
Just s -> recurse ((\x -> forceThunk (coerce x) pure) <$> s)
|
|
||||||
-- TODO: Keep a stack of attributes we've already traversed, so
|
|
||||||
-- that we can report that to the user
|
|
||||||
x -> throwError $ "attribute " ++ show p
|
|
||||||
++ " is not a set, but a " ++ show (void x)
|
|
||||||
where
|
|
||||||
go = return $ M.insert p val m
|
|
||||||
|
|
||||||
recurse s = attrSetAlter ps s val >>= \m' ->
|
|
||||||
if | M.null m' -> return m
|
|
||||||
| otherwise -> do
|
|
||||||
scope <- currentScopes @_ @t
|
|
||||||
return $ M.insert p (embed scope m') m
|
|
||||||
where
|
|
||||||
embed scope m' = embedSet @t @v @m
|
|
||||||
=<< traverse (fmap coerce . buildThunk . withScopes scope) m'
|
|
||||||
|
|
||||||
evalBinds
|
|
||||||
:: forall e t v m. (MonadExpr t v m, Scoped e t m, Framed e m,
|
|
||||||
MonadVar m, MonadFix m, MonadFile m)
|
|
||||||
=> Bool
|
|
||||||
-> Bool
|
|
||||||
-> [Binding (m v)]
|
|
||||||
-> m (HashMap Text t, HashMap Text Delta)
|
|
||||||
evalBinds allowDynamic recursive =
|
|
||||||
buildResult . concat <=< mapM go . moveOverridesLast
|
|
||||||
where
|
|
||||||
moveOverridesLast = (\(x, y) -> y ++ x) .
|
|
||||||
partition (\case NamedVar [StaticKey "__overrides" _] _ -> True
|
|
||||||
_ -> False)
|
|
||||||
|
|
||||||
go :: Binding (m v) -> m [([Text], Maybe Delta, m v)]
|
|
||||||
go (NamedVar [StaticKey "__overrides" _] finalValue) =
|
|
||||||
finalValue >>= projectSetWithPos >>= \case
|
|
||||||
Just (o', p') -> return $
|
|
||||||
map (\(k, v) -> ([k], M.lookup k p',
|
|
||||||
forceThunk (coerce v) pure))
|
|
||||||
(M.toList o')
|
|
||||||
x -> throwError $ "__overrides must be a set, but saw: "
|
|
||||||
++ show (void x)
|
|
||||||
|
|
||||||
go (NamedVar pathExpr finalValue) = do
|
|
||||||
let go :: NAttrPath (m v) -> m ([Text], Maybe Delta, m v)
|
|
||||||
go = \case
|
|
||||||
[] -> pure ([], Nothing, finalValue)
|
|
||||||
h : t -> evalSetterKeyName allowDynamic h >>= \case
|
|
||||||
(Nothing, _) ->
|
|
||||||
pure ([], Nothing, embedSet mempty)
|
|
||||||
(Just k, pos) -> do
|
|
||||||
(restOfPath, _, v) <- go t
|
|
||||||
pure (k : restOfPath, pos, v)
|
|
||||||
go pathExpr <&> \case
|
|
||||||
-- When there are no path segments, e.g. `${null} = 5;`, we don't
|
|
||||||
-- bind anything
|
|
||||||
([], _, _) -> []
|
|
||||||
result -> [result]
|
|
||||||
|
|
||||||
go (Inherit ms names) = fmap catMaybes $ forM names $ \name ->
|
|
||||||
evalSetterKeyName allowDynamic name >>= \case
|
|
||||||
(Nothing, _) -> return Nothing
|
|
||||||
(Just key, pos) -> return $ Just ([key], pos, do
|
|
||||||
mv <- case ms of
|
|
||||||
Nothing -> lookupVar key
|
|
||||||
Just s -> s >>= projectSet >>= \case
|
|
||||||
Just s -> pushScope s (lookupVar @_ @t key)
|
|
||||||
x -> throwError
|
|
||||||
$ "First argument to inherit should be a set, saw: "
|
|
||||||
++ show (void x)
|
|
||||||
case mv of
|
|
||||||
Nothing -> throwError $ "Inheriting unknown attribute: "
|
|
||||||
++ show (void name)
|
|
||||||
Just v -> forceThunk (coerce v) pure)
|
|
||||||
|
|
||||||
buildResult :: [([Text], Maybe Delta, m v)]
|
|
||||||
-> m (HashMap Text t, HashMap Text Delta)
|
|
||||||
buildResult bindings = do
|
|
||||||
s <- foldM insert M.empty bindings
|
|
||||||
scope <- currentScopes @_ @t
|
|
||||||
res <- if recursive
|
|
||||||
then loebM (encapsulate scope <$> s)
|
|
||||||
else traverse (fmap coerce . buildThunk . withScopes scope) s
|
|
||||||
traceM $ "buildResult: " ++ show (map (\(k, v, _) -> (k, v)) bindings)
|
|
||||||
return (res, foldl' go M.empty bindings)
|
|
||||||
where
|
|
||||||
go m ([k], Just pos, _) = M.insert k pos m
|
|
||||||
go m _ = m
|
|
||||||
|
|
||||||
encapsulate scope f attrs =
|
|
||||||
fmap coerce . buildThunk . withScopes scope . pushScope attrs $ f
|
|
||||||
|
|
||||||
insert m (path, _, value) = attrSetAlter path m value
|
|
||||||
|
|
||||||
evalSelect
|
|
||||||
:: (MonadExpr t v m, Framed e m, MonadVar m, MonadFile m)
|
|
||||||
=> m (NValue m)
|
|
||||||
-> NAttrPath (m v)
|
|
||||||
-> m (Either (NValueF m (NThunk m), [Text]) (NValueF m (NThunk m)))
|
|
||||||
evalSelect aset attr =
|
|
||||||
join $ extract <$> aset <*> evalSelector True attr
|
|
||||||
where
|
|
||||||
extract (NVSet s p) (k:ks) = case M.lookup k s of
|
|
||||||
Just v -> force v $ extract ?? ks
|
|
||||||
Nothing -> return $ Left (NVSet s p, k:ks)
|
|
||||||
extract x (k:ks) = return $ Left (x, k:ks)
|
|
||||||
extract v [] = return $ Right v
|
|
||||||
|
|
||||||
evalSelector :: (Framed e m, MonadExpr t v m, MonadFile m)
|
|
||||||
=> Bool -> NAttrPath (m v) -> m [Text]
|
|
||||||
evalSelector allowDynamic =
|
|
||||||
fmap (map fst) <$> mapM (evalGetterKeyName allowDynamic)
|
|
||||||
|
|
||||||
evalKeyNameStatic :: (Framed e m, MonadExpr t v m, MonadFile m)
|
|
||||||
=> NKeyName (m v) -> m (Text, Maybe Delta)
|
|
||||||
evalKeyNameStatic = \case
|
|
||||||
StaticKey k p -> pure (k, p)
|
|
||||||
DynamicKey _ -> throwError "dynamic attribute not allowed in this context"
|
|
||||||
|
|
||||||
-- | Returns Nothing iff the key value is null
|
|
||||||
evalKeyNameDynamicNullable :: (Framed e m, MonadExpr t v m, MonadFile m)
|
|
||||||
=> NKeyName (m v) -> m (Maybe Text, Maybe Delta)
|
|
||||||
evalKeyNameDynamicNullable = \case
|
|
||||||
StaticKey k p -> pure (Just k, p)
|
|
||||||
DynamicKey k -> runAntiquoted evalString id k >>= projectText >>= \case
|
|
||||||
Just (Just s) -> (\x -> (Just x, Nothing)) <$> unwrapText s
|
|
||||||
Just Nothing -> return (Nothing, Nothing)
|
|
||||||
bad -> throwError $ "evaluating key name: expected string, got "
|
|
||||||
++ show (void bad)
|
|
||||||
|
|
||||||
evalKeyNameDynamicNotNull :: (Framed e m, MonadExpr t v m, MonadFile m)
|
|
||||||
=> NKeyName (m v) -> m (Text, Maybe Delta)
|
|
||||||
evalKeyNameDynamicNotNull = evalKeyNameDynamicNullable >=> \case
|
|
||||||
(Nothing, _) -> throwError "value is null while a string was expected"
|
|
||||||
(Just k, p) -> pure (k, p)
|
|
||||||
|
|
||||||
-- | Evaluate a component of an attribute path in a context where we are
|
|
||||||
-- *binding* a value
|
|
||||||
evalSetterKeyName :: (Framed e m, MonadExpr t v m, MonadFile m)
|
|
||||||
=> Bool -> NKeyName (m v) -> m (Maybe Text, Maybe Delta)
|
|
||||||
evalSetterKeyName canBeDynamic
|
|
||||||
| canBeDynamic = evalKeyNameDynamicNullable
|
|
||||||
| otherwise = fmap (first Just) . evalKeyNameStatic
|
|
||||||
|
|
||||||
-- | Evaluate a component of an attribute path in a context where we are
|
|
||||||
-- *retrieving* a value
|
|
||||||
evalGetterKeyName :: (Framed e m, MonadExpr t v m, MonadFile m)
|
|
||||||
=> Bool -> NKeyName (m v) -> m (Text, Maybe Delta)
|
|
||||||
evalGetterKeyName canBeDynamic
|
|
||||||
| canBeDynamic = evalKeyNameDynamicNotNull
|
|
||||||
| otherwise = evalKeyNameStatic
|
|
||||||
|
|
||||||
evalString :: forall e t v m. (Framed e m, MonadExpr t v m, MonadFile m)
|
|
||||||
=> NString (m v) -> m v
|
|
||||||
evalString = \case
|
|
||||||
Indented parts -> fromParts parts
|
|
||||||
DoubleQuoted parts -> fromParts parts
|
|
||||||
where
|
|
||||||
go = runAntiquoted (wrapText @t @v @m) $ \x -> do
|
|
||||||
x' <- x
|
|
||||||
projectText @t @v @m x' >>= \case
|
|
||||||
Just (Just txt) -> return txt
|
|
||||||
_ -> throwError "Value cannot be rendered as text"
|
|
||||||
|
|
||||||
fromParts parts = embedText @t @v @m . mconcat =<< mapM go parts
|
|
||||||
|
|
||||||
-----
|
|
||||||
|
|
||||||
tracingEvalExpr :: (Framed e m, MonadIO n, Alternative n)
|
|
||||||
=> (NExprF (m v) -> m v) -> NExprLoc -> n (m v)
|
|
||||||
tracingEvalExpr eval =
|
|
||||||
flip runReaderT (0 :: Int)
|
|
||||||
. adiM (pure <$> eval . annotated . getCompose) psi
|
|
||||||
where
|
|
||||||
psi k v@(Fix x) = do
|
|
||||||
depth <- ask
|
|
||||||
guard (depth < 200)
|
|
||||||
liftIO $ putStrLn $ "eval: " ++ replicate (depth * 2) ' '
|
|
||||||
++ show (stripAnnotation v)
|
|
||||||
res <- local succ $
|
|
||||||
fmap (withExprContext (void x)) (k v)
|
|
||||||
liftIO $ putStrLn $ "eval: " ++ replicate (depth * 2) ' ' ++ "."
|
|
||||||
return res
|
|
||||||
|
|
||||||
framedEvalExpr :: Framed e m
|
|
||||||
=> (NExprF (m v) -> m v) -> NExprLoc -> m v
|
|
||||||
framedEvalExpr eval = adi (eval . annotated . getCompose) psi
|
|
||||||
where
|
|
||||||
psi k v@(Fix x) = withExprContext (void x) (k v)
|
|
||||||
|
|
||||||
-----
|
|
||||||
|
|
||||||
{-
|
|
||||||
streamValues :: MonadVar m => NValue m -> Stream (NValueF m) m ()
|
|
||||||
streamValues = void . yields . fmap go
|
|
||||||
where
|
|
||||||
go (NThunk (Left v)) = streamValues v
|
|
||||||
go (NThunk v) = effect (streamValues <$> forceThunk v)
|
|
||||||
-}
|
|
10
Nix/Expr.hs
10
Nix/Expr.hs
|
@ -1,10 +0,0 @@
|
||||||
-- | Wraps the expression submodules.
|
|
||||||
module Nix.Expr (
|
|
||||||
module Nix.Expr.Types,
|
|
||||||
module Nix.Expr.Types.Annotated,
|
|
||||||
module Nix.Expr.Shorthands
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Nix.Expr.Types
|
|
||||||
import Nix.Expr.Shorthands
|
|
||||||
import Nix.Expr.Types.Annotated
|
|
|
@ -1,235 +0,0 @@
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
-- | A bunch of shorthands for making nix expressions.
|
|
||||||
--
|
|
||||||
-- Functions with an @F@ suffix return a more general type without the outer
|
|
||||||
-- 'Fix' wrapper.
|
|
||||||
module Nix.Expr.Shorthands where
|
|
||||||
|
|
||||||
import Data.Fix
|
|
||||||
import qualified Data.HashMap.Strict.InsOrd as M
|
|
||||||
import Data.Monoid
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Nix.Atoms
|
|
||||||
import Nix.Expr.Types
|
|
||||||
import Nix.Utils
|
|
||||||
|
|
||||||
-- | Make an integer literal expression.
|
|
||||||
mkInt :: Integer -> NExpr
|
|
||||||
mkInt = Fix . mkIntF
|
|
||||||
|
|
||||||
mkIntF :: Integer -> NExprF a
|
|
||||||
mkIntF = NConstant . NInt
|
|
||||||
|
|
||||||
-- | Make an floating point literal expression.
|
|
||||||
mkFloat :: Float -> NExpr
|
|
||||||
mkFloat = Fix . mkFloatF
|
|
||||||
|
|
||||||
mkFloatF :: Float -> NExprF a
|
|
||||||
mkFloatF = NConstant . NFloat
|
|
||||||
|
|
||||||
-- | Make a regular (double-quoted) string.
|
|
||||||
mkStr :: Text -> NExpr
|
|
||||||
mkStr = Fix . NStr . DoubleQuoted . \case
|
|
||||||
"" -> []
|
|
||||||
x -> [Plain x]
|
|
||||||
|
|
||||||
-- | Make an indented string.
|
|
||||||
mkIndentedStr :: Text -> NExpr
|
|
||||||
mkIndentedStr = Fix . NStr . Indented . \case
|
|
||||||
"" -> []
|
|
||||||
x -> [Plain x]
|
|
||||||
|
|
||||||
-- | Make a literal URI expression.
|
|
||||||
mkUri :: Text -> NExpr
|
|
||||||
mkUri = Fix . mkUriF
|
|
||||||
|
|
||||||
mkUriF :: Text -> NExprF a
|
|
||||||
mkUriF = NConstant . NUri
|
|
||||||
|
|
||||||
-- | Make a path. Use 'True' if the path should be read from the
|
|
||||||
-- environment, else 'False'.
|
|
||||||
mkPath :: Bool -> FilePath -> NExpr
|
|
||||||
mkPath b = Fix . mkPathF b
|
|
||||||
|
|
||||||
mkPathF :: Bool -> FilePath -> NExprF a
|
|
||||||
mkPathF False = NLiteralPath
|
|
||||||
mkPathF True = NEnvPath
|
|
||||||
|
|
||||||
-- | Make a path expression which pulls from the NIX_PATH env variable.
|
|
||||||
mkEnvPath :: FilePath -> NExpr
|
|
||||||
mkEnvPath = Fix . mkEnvPathF
|
|
||||||
|
|
||||||
mkEnvPathF :: FilePath -> NExprF a
|
|
||||||
mkEnvPathF = mkPathF True
|
|
||||||
|
|
||||||
-- | Make a path expression which references a relative path.
|
|
||||||
mkRelPath :: FilePath -> NExpr
|
|
||||||
mkRelPath = Fix . mkRelPathF
|
|
||||||
|
|
||||||
mkRelPathF :: FilePath -> NExprF a
|
|
||||||
mkRelPathF = mkPathF False
|
|
||||||
|
|
||||||
-- | Make a variable (symbol)
|
|
||||||
mkSym :: Text -> NExpr
|
|
||||||
mkSym = Fix . mkSymF
|
|
||||||
|
|
||||||
mkSymF :: Text -> NExprF a
|
|
||||||
mkSymF = NSym
|
|
||||||
|
|
||||||
mkSelector :: Text -> NAttrPath NExpr
|
|
||||||
mkSelector = (:[]) . flip StaticKey Nothing
|
|
||||||
|
|
||||||
mkBool :: Bool -> NExpr
|
|
||||||
mkBool = Fix . mkBoolF
|
|
||||||
|
|
||||||
mkBoolF :: Bool -> NExprF a
|
|
||||||
mkBoolF = NConstant . NBool
|
|
||||||
|
|
||||||
mkNull :: NExpr
|
|
||||||
mkNull = Fix mkNullF
|
|
||||||
|
|
||||||
mkNullF :: NExprF a
|
|
||||||
mkNullF = NConstant NNull
|
|
||||||
|
|
||||||
mkOper :: NUnaryOp -> NExpr -> NExpr
|
|
||||||
mkOper op = Fix . NUnary op
|
|
||||||
|
|
||||||
mkOper2 :: NBinaryOp -> NExpr -> NExpr -> NExpr
|
|
||||||
mkOper2 op a = Fix . NBinary op a
|
|
||||||
|
|
||||||
mkParamset :: [(Text, Maybe NExpr)] -> Bool -> Params NExpr
|
|
||||||
mkParamset params variadic = ParamSet (M.fromList params) variadic Nothing
|
|
||||||
|
|
||||||
mkApp :: NExpr -> NExpr -> NExpr
|
|
||||||
mkApp e = Fix . NApp e
|
|
||||||
|
|
||||||
mkRecSet :: [Binding NExpr] -> NExpr
|
|
||||||
mkRecSet = Fix . NRecSet
|
|
||||||
|
|
||||||
mkNonRecSet :: [Binding NExpr] -> NExpr
|
|
||||||
mkNonRecSet = Fix . NSet
|
|
||||||
|
|
||||||
mkLets :: [Binding NExpr] -> NExpr -> NExpr
|
|
||||||
mkLets bindings = Fix . NLet bindings
|
|
||||||
|
|
||||||
mkList :: [NExpr] -> NExpr
|
|
||||||
mkList = Fix . NList
|
|
||||||
|
|
||||||
mkWith :: NExpr -> NExpr -> NExpr
|
|
||||||
mkWith e = Fix . NWith e
|
|
||||||
|
|
||||||
mkAssert :: NExpr -> NExpr -> NExpr
|
|
||||||
mkAssert e = Fix . NWith e
|
|
||||||
|
|
||||||
mkIf :: NExpr -> NExpr -> NExpr -> NExpr
|
|
||||||
mkIf e1 e2 = Fix . NIf e1 e2
|
|
||||||
|
|
||||||
mkFunction :: Params NExpr -> NExpr -> NExpr
|
|
||||||
mkFunction params = Fix . NAbs params
|
|
||||||
|
|
||||||
mkDot :: NExpr -> Text -> NExpr
|
|
||||||
mkDot e key = mkDots e [key]
|
|
||||||
|
|
||||||
-- | Create a dotted expression using only text.
|
|
||||||
mkDots :: NExpr -> [Text] -> NExpr
|
|
||||||
mkDots e [] = e
|
|
||||||
mkDots (Fix (NSelect e keys' x)) keys =
|
|
||||||
-- Special case: if the expression in the first argument is already
|
|
||||||
-- a dotted expression, just extend it.
|
|
||||||
Fix (NSelect e (keys' <> map (StaticKey ?? Nothing) keys) x)
|
|
||||||
mkDots e keys = Fix $ NSelect e (map (StaticKey ?? Nothing) keys) Nothing
|
|
||||||
|
|
||||||
-- | An `inherit` clause without an expression to pull from.
|
|
||||||
inherit :: [NKeyName e] -> Binding e
|
|
||||||
inherit = Inherit Nothing
|
|
||||||
|
|
||||||
-- | An `inherit` clause with an expression to pull from.
|
|
||||||
inheritFrom :: e -> [NKeyName e] -> Binding e
|
|
||||||
inheritFrom expr = Inherit (Just expr)
|
|
||||||
|
|
||||||
-- | Shorthand for producing a binding of a name to an expression.
|
|
||||||
bindTo :: Text -> NExpr -> Binding NExpr
|
|
||||||
bindTo name = NamedVar (mkSelector name)
|
|
||||||
|
|
||||||
-- | Infix version of bindTo.
|
|
||||||
($=) :: Text -> NExpr -> Binding NExpr
|
|
||||||
($=) = bindTo
|
|
||||||
|
|
||||||
infixr 2 $=
|
|
||||||
|
|
||||||
-- | Append a list of bindings to a set or let expression.
|
|
||||||
-- For example, adding `[a = 1, b = 2]` to `let c = 3; in 4` produces
|
|
||||||
-- `let a = 1; b = 2; c = 3; in 4`.
|
|
||||||
appendBindings :: [Binding NExpr] -> NExpr -> NExpr
|
|
||||||
appendBindings newBindings (Fix e) = case e of
|
|
||||||
NLet bindings e' -> Fix $ NLet (bindings <> newBindings) e'
|
|
||||||
NSet bindings -> Fix $ NSet (bindings <> newBindings)
|
|
||||||
NRecSet bindings -> Fix $ NRecSet (bindings <> newBindings)
|
|
||||||
_ -> error "Can only append bindings to a set or a let"
|
|
||||||
|
|
||||||
-- | Applies a transformation to the body of a nix function.
|
|
||||||
modifyFunctionBody :: (NExpr -> NExpr) -> NExpr -> NExpr
|
|
||||||
modifyFunctionBody f (Fix e) = case e of
|
|
||||||
NAbs params body -> Fix $ NAbs params (f body)
|
|
||||||
_ -> error "Not a function"
|
|
||||||
|
|
||||||
-- | A let statement with multiple assignments.
|
|
||||||
letsE :: [(Text, NExpr)] -> NExpr -> NExpr
|
|
||||||
letsE pairs = Fix . NLet (map (uncurry bindTo) pairs)
|
|
||||||
|
|
||||||
-- | Wrapper for a single-variable @let@.
|
|
||||||
letE :: Text -> NExpr -> NExpr -> NExpr
|
|
||||||
letE varName varExpr = letsE [(varName, varExpr)]
|
|
||||||
|
|
||||||
-- | Make an attribute set (non-recursive).
|
|
||||||
attrsE :: [(Text, NExpr)] -> NExpr
|
|
||||||
attrsE pairs = Fix $ NSet (map (uncurry bindTo) pairs)
|
|
||||||
|
|
||||||
-- | Make an attribute set (recursive).
|
|
||||||
recAttrsE :: [(Text, NExpr)] -> NExpr
|
|
||||||
recAttrsE pairs = Fix $ NRecSet (map (uncurry bindTo) pairs)
|
|
||||||
|
|
||||||
-- | Logical negation.
|
|
||||||
mkNot :: NExpr -> NExpr
|
|
||||||
mkNot = Fix . NUnary NNot
|
|
||||||
|
|
||||||
-- | Dot-reference into an attribute set.
|
|
||||||
(!.) :: NExpr -> Text -> NExpr
|
|
||||||
(!.) = mkDot
|
|
||||||
infixl 8 !.
|
|
||||||
|
|
||||||
mkBinop :: NBinaryOp -> NExpr -> NExpr -> NExpr
|
|
||||||
mkBinop op e1 e2 = Fix (NBinary op e1 e2)
|
|
||||||
|
|
||||||
-- | Various nix binary operators
|
|
||||||
($==), ($!=), ($<), ($<=), ($>), ($>=), ($&&), ($||), ($->),
|
|
||||||
($//), ($+), ($-), ($*), ($/), ($++)
|
|
||||||
:: NExpr -> NExpr -> NExpr
|
|
||||||
e1 $== e2 = mkBinop NEq e1 e2
|
|
||||||
e1 $!= e2 = mkBinop NNEq e1 e2
|
|
||||||
e1 $< e2 = mkBinop NLt e1 e2
|
|
||||||
e1 $<= e2 = mkBinop NLte e1 e2
|
|
||||||
e1 $> e2 = mkBinop NGt e1 e2
|
|
||||||
e1 $>= e2 = mkBinop NGte e1 e2
|
|
||||||
e1 $&& e2 = mkBinop NAnd e1 e2
|
|
||||||
e1 $|| e2 = mkBinop NOr e1 e2
|
|
||||||
e1 $-> e2 = mkBinop NImpl e1 e2
|
|
||||||
e1 $// e2 = mkBinop NUpdate e1 e2
|
|
||||||
e1 $+ e2 = mkBinop NPlus e1 e2
|
|
||||||
e1 $- e2 = mkBinop NMinus e1 e2
|
|
||||||
e1 $* e2 = mkBinop NMult e1 e2
|
|
||||||
e1 $/ e2 = mkBinop NDiv e1 e2
|
|
||||||
e1 $++ e2 = mkBinop NConcat e1 e2
|
|
||||||
|
|
||||||
-- | Function application expression.
|
|
||||||
(@@) :: NExpr -> NExpr -> NExpr
|
|
||||||
(@@) = mkApp
|
|
||||||
infixl 1 @@
|
|
||||||
|
|
||||||
-- | Lambda shorthand.
|
|
||||||
(==>) :: Params NExpr -> NExpr -> NExpr
|
|
||||||
(==>) = mkFunction
|
|
||||||
|
|
||||||
infixr 1 ==>
|
|
|
@ -1,255 +0,0 @@
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE DeriveTraversable #-}
|
|
||||||
{-# LANGUAGE DeriveFoldable #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
-- | The nix expression type and supporting types.
|
|
||||||
module Nix.Expr.Types where
|
|
||||||
|
|
||||||
import Data.Data
|
|
||||||
import Data.Eq.Deriving
|
|
||||||
import Data.Fix
|
|
||||||
import Data.Functor.Classes
|
|
||||||
import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
|
|
||||||
import Data.Text (Text, pack)
|
|
||||||
import Data.Traversable
|
|
||||||
import GHC.Exts
|
|
||||||
import GHC.Generics
|
|
||||||
import Nix.Atoms
|
|
||||||
import Nix.Parser.Library (Delta(..))
|
|
||||||
import Nix.Utils
|
|
||||||
import Text.Show.Deriving
|
|
||||||
|
|
||||||
type VarName = Text
|
|
||||||
|
|
||||||
-- | 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).
|
|
||||||
| NApp !r !r
|
|
||||||
-- ^ Apply a function to an argument.
|
|
||||||
| 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.
|
|
||||||
deriving (Ord, Eq, Generic, Typeable, Data, Functor,
|
|
||||||
Foldable, Traversable, Show)
|
|
||||||
|
|
||||||
-- | 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
|
|
||||||
|
|
||||||
|
|
||||||
-- | The monomorphic expression type is a fixed point of the polymorphic one.
|
|
||||||
type NExpr = Fix NExprF
|
|
||||||
|
|
||||||
-- | A single line of the bindings section of a let expression or of a set.
|
|
||||||
data Binding r
|
|
||||||
= NamedVar !(NAttrPath r) !r
|
|
||||||
-- ^ An explicit naming, such as @x = y@ or @x.y = z@.
|
|
||||||
| Inherit !(Maybe r) !(NAttrPath r)
|
|
||||||
-- ^ 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;@.
|
|
||||||
deriving (Typeable, Data, Ord, Eq, Functor, Foldable, Traversable, Show)
|
|
||||||
|
|
||||||
-- | @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, Typeable, Data, Functor, Show,
|
|
||||||
Foldable, Traversable)
|
|
||||||
|
|
||||||
-- This uses InsOrdHashMap because nix XML serialization preserves the order of
|
|
||||||
-- the param set.
|
|
||||||
type ParamSet r = InsOrdHashMap 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 | Antiquoted !r
|
|
||||||
deriving (Ord, Eq, Generic, Typeable, Data, Functor, Foldable, Traversable, Show)
|
|
||||||
|
|
||||||
-- | 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 ![Antiquoted Text r]
|
|
||||||
-- ^ Strings wrapped with two single quotes ('') can contain newlines,
|
|
||||||
-- and their indentation will be stripped.
|
|
||||||
deriving (Eq, Ord, Generic, Typeable, Data, Functor, Foldable, Traversable, Show)
|
|
||||||
|
|
||||||
-- | 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 at the right 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 !(Maybe Delta)
|
|
||||||
deriving (Eq, Ord, Generic, Typeable, Data, Show)
|
|
||||||
|
|
||||||
-- | Most key names are just static text, so this instance is convenient.
|
|
||||||
instance IsString (NKeyName r) where
|
|
||||||
fromString = flip StaticKey Nothing . 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
|
|
||||||
|
|
||||||
-- 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
|
|
||||||
StaticKey key pos -> pure (StaticKey key pos)
|
|
||||||
|
|
||||||
-- | A selector (for example in a @let@ or an attribute set) is made up
|
|
||||||
-- of strung-together key names.
|
|
||||||
type NAttrPath r = [NKeyName r]
|
|
||||||
|
|
||||||
-- | There are two unary operations: logical not and integer negation.
|
|
||||||
data NUnaryOp = NNeg | NNot
|
|
||||||
deriving (Eq, Ord, Generic, Typeable, Data, Show)
|
|
||||||
|
|
||||||
-- | 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 attribut sets (//)
|
|
||||||
| NPlus -- ^ Addition (+)
|
|
||||||
| NMinus -- ^ Subtraction (-)
|
|
||||||
| NMult -- ^ Multiplication (*)
|
|
||||||
| NDiv -- ^ Division (/)
|
|
||||||
| NConcat -- ^ List concatenation (++)
|
|
||||||
deriving (Eq, Ord, Generic, Typeable, Data, Show)
|
|
||||||
|
|
||||||
-- | 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
|
|
||||||
|
|
||||||
$(deriveEq1 ''NExprF)
|
|
||||||
$(deriveEq1 ''NString)
|
|
||||||
$(deriveEq1 ''Binding)
|
|
||||||
$(deriveEq1 ''Params)
|
|
||||||
$(deriveEq1 ''Antiquoted)
|
|
||||||
$(deriveEq2 ''Antiquoted)
|
|
||||||
|
|
||||||
$(deriveShow1 ''NExprF)
|
|
||||||
$(deriveShow1 ''NString)
|
|
||||||
$(deriveShow1 ''Params)
|
|
||||||
$(deriveShow1 ''Binding)
|
|
||||||
$(deriveShow1 ''Antiquoted)
|
|
||||||
$(deriveShow2 ''Antiquoted)
|
|
||||||
|
|
||||||
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 (NSelect s attr alt) = NSelect s (map clear attr) alt
|
|
||||||
phi x = x
|
|
||||||
|
|
||||||
go (NamedVar path r) = NamedVar (map clear path) r
|
|
||||||
go (Inherit ms names) = Inherit ms (map clear names)
|
|
||||||
|
|
||||||
clear (StaticKey name _) = StaticKey name Nothing
|
|
||||||
clear k = k
|
|
|
@ -1,100 +0,0 @@
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
|
||||||
{-# LANGUAGE DeriveFoldable #-}
|
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE DeriveTraversable #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE KindSignatures #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE PatternSynonyms #-}
|
|
||||||
{-# LANGUAGE RankNTypes #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
|
|
||||||
-- | The source location annotated nix expression type and supporting types.
|
|
||||||
--
|
|
||||||
module Nix.Expr.Types.Annotated
|
|
||||||
( module Nix.Expr.Types.Annotated
|
|
||||||
, Delta(..)
|
|
||||||
)where
|
|
||||||
|
|
||||||
import Data.Data
|
|
||||||
import Data.Fix
|
|
||||||
import Data.Function (on)
|
|
||||||
import Data.Functor.Compose
|
|
||||||
import Data.Semigroup
|
|
||||||
import GHC.Generics
|
|
||||||
import Nix.Expr.Types
|
|
||||||
import Nix.Parser.Library (Delta(..))
|
|
||||||
import Text.Show.Deriving
|
|
||||||
|
|
||||||
-- | A location in a source file
|
|
||||||
data SrcSpan = SrcSpan{ spanBegin :: Delta
|
|
||||||
, spanEnd :: Delta
|
|
||||||
}
|
|
||||||
deriving (Ord, Eq, Generic, Typeable, Data, Show)
|
|
||||||
|
|
||||||
-- | A type constructor applied to a type along with an annotation
|
|
||||||
--
|
|
||||||
-- Intended to be used with 'Fix':
|
|
||||||
-- @type MyType = Fix (Compose (Ann Annotation) F)@
|
|
||||||
data Ann ann a = Ann{ annotation :: ann
|
|
||||||
, annotated :: a
|
|
||||||
}
|
|
||||||
deriving (Ord, Eq, Data, Generic, Typeable, Functor,
|
|
||||||
Foldable, Traversable, Read, Show)
|
|
||||||
|
|
||||||
$(deriveShow1 ''Ann)
|
|
||||||
|
|
||||||
instance Semigroup SrcSpan where
|
|
||||||
s1 <> s2 = SrcSpan ((min `on` spanBegin) s1 s2)
|
|
||||||
((max `on` spanEnd) s1 s2)
|
|
||||||
|
|
||||||
type AnnF ann f = Compose (Ann ann) f
|
|
||||||
|
|
||||||
annToAnnF :: Ann ann (f (Fix (AnnF ann f))) -> Fix (AnnF ann f)
|
|
||||||
annToAnnF (Ann ann a) = AnnE ann a
|
|
||||||
|
|
||||||
type NExprLocF = AnnF SrcSpan NExprF
|
|
||||||
|
|
||||||
-- | A nix expression with source location at each subexpression.
|
|
||||||
type NExprLoc = Fix NExprLocF
|
|
||||||
|
|
||||||
pattern AnnE :: forall ann (g :: * -> *). ann
|
|
||||||
-> g (Fix (Compose (Ann ann) g)) -> Fix (Compose (Ann ann) g)
|
|
||||||
pattern AnnE ann a = Fix (Compose (Ann ann a))
|
|
||||||
|
|
||||||
stripAnnotation :: Functor f => Fix (AnnF ann f) -> Fix f
|
|
||||||
stripAnnotation = ana (annotated . getCompose . unFix)
|
|
||||||
|
|
||||||
nApp :: NExprLoc -> NExprLoc -> NExprLoc
|
|
||||||
nApp e1@(AnnE s1 _) e2@(AnnE s2 _) = AnnE (s1 <> s2) (NApp e1 e2)
|
|
||||||
nApp _ _ = error "nApp: unexpected"
|
|
||||||
|
|
||||||
nUnary :: Ann SrcSpan NUnaryOp -> NExprLoc -> NExprLoc
|
|
||||||
nUnary (Ann s1 u) e1@(AnnE s2 _) = AnnE (s1 <> s2) (NUnary u e1)
|
|
||||||
nUnary _ _ = error "nUnary: unexpected"
|
|
||||||
|
|
||||||
nBinary :: Ann SrcSpan NBinaryOp -> NExprLoc -> NExprLoc -> NExprLoc
|
|
||||||
nBinary (Ann s1 b) e1@(AnnE s2 _) e2@(AnnE s3 _) =
|
|
||||||
AnnE (s1 <> s2 <> s3) (NBinary b e1 e2)
|
|
||||||
nBinary _ _ _ = error "nBinary: unexpected"
|
|
||||||
|
|
||||||
nSelectLoc :: NExprLoc -> Ann SrcSpan (NAttrPath NExprLoc) -> Maybe NExprLoc
|
|
||||||
-> NExprLoc
|
|
||||||
nSelectLoc e1@(AnnE s1 _) (Ann s2 ats) d = case d of
|
|
||||||
Nothing -> AnnE (s1 <> s2) (NSelect e1 ats Nothing)
|
|
||||||
Just (e2@(AnnE s3 _)) -> AnnE (s1 <> s2 <> s3) (NSelect e1 ats (Just e2))
|
|
||||||
_ -> error "nSelectLoc: unexpected"
|
|
||||||
nSelectLoc _ _ _ = error "nSelectLoc: unexpected"
|
|
||||||
|
|
||||||
nHasAttr :: NExprLoc -> Ann SrcSpan (NAttrPath NExprLoc) -> NExprLoc
|
|
||||||
nHasAttr e1@(AnnE s1 _) (Ann s2 ats) = AnnE (s1 <> s2) (NHasAttr e1 ats)
|
|
||||||
nHasAttr _ _ = error "nHasAttr: unexpected"
|
|
||||||
|
|
||||||
nAbs :: Ann SrcSpan (Params NExprLoc) -> NExprLoc -> NExprLoc
|
|
||||||
nAbs (Ann s1 ps) e1@(AnnE s2 _) = AnnE (s1 <> s2) (NAbs ps e1)
|
|
||||||
nAbs _ _ = error "nAbs: unexpected"
|
|
||||||
|
|
||||||
nStr :: Ann SrcSpan (NString NExprLoc) -> NExprLoc
|
|
||||||
nStr (Ann s1 s) = AnnE s1 (NStr s)
|
|
399
Nix/Lint.hs
399
Nix/Lint.hs
|
@ -1,399 +0,0 @@
|
||||||
{-# LANGUAGE ConstraintKinds #-}
|
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
|
||||||
{-# LANGUAGE DeriveFoldable #-}
|
|
||||||
{-# LANGUAGE DeriveTraversable #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE KindSignatures #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE MultiWayIf #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE TupleSections #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
|
|
||||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
|
||||||
|
|
||||||
module Nix.Lint where
|
|
||||||
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.Fix
|
|
||||||
import Data.Coerce
|
|
||||||
import Data.Fix
|
|
||||||
import Data.HashMap.Lazy (HashMap)
|
|
||||||
import qualified Data.HashMap.Lazy as M
|
|
||||||
import qualified Data.HashMap.Strict.InsOrd as OM
|
|
||||||
import Data.List
|
|
||||||
import Data.Maybe
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Nix.Atoms
|
|
||||||
import Nix.Eval
|
|
||||||
import Nix.Expr
|
|
||||||
import Nix.Scope
|
|
||||||
import Nix.Stack
|
|
||||||
import Nix.Thunk
|
|
||||||
import Nix.Utils
|
|
||||||
|
|
||||||
data TAtom
|
|
||||||
= TInt
|
|
||||||
| TFloat
|
|
||||||
| TBool
|
|
||||||
| TNull
|
|
||||||
| TUri
|
|
||||||
deriving (Show, Eq, Ord)
|
|
||||||
|
|
||||||
data NTypeF (m :: * -> *) r
|
|
||||||
= TConstant [TAtom]
|
|
||||||
| TStr
|
|
||||||
| TList r
|
|
||||||
| TSet (Maybe (HashMap Text r))
|
|
||||||
| TClosure (Scopes m r) (Params (m r)) (m r)
|
|
||||||
| TPath
|
|
||||||
| TBuiltin String (Symbolic m -> m r)
|
|
||||||
deriving Functor
|
|
||||||
|
|
||||||
compareTypes :: NTypeF m r -> NTypeF m r -> Ordering
|
|
||||||
compareTypes (TConstant _) (TConstant _) = EQ
|
|
||||||
compareTypes (TConstant _) _ = LT
|
|
||||||
compareTypes _ (TConstant _) = GT
|
|
||||||
compareTypes TStr TStr = EQ
|
|
||||||
compareTypes TStr _ = LT
|
|
||||||
compareTypes _ TStr = GT
|
|
||||||
compareTypes (TList _) (TList _) = EQ
|
|
||||||
compareTypes (TList _) _ = LT
|
|
||||||
compareTypes _ (TList _) = GT
|
|
||||||
compareTypes (TSet _) (TSet _) = EQ
|
|
||||||
compareTypes (TSet _) _ = LT
|
|
||||||
compareTypes _ (TSet _) = GT
|
|
||||||
compareTypes TClosure {} TClosure {} = EQ
|
|
||||||
compareTypes TClosure {} _ = LT
|
|
||||||
compareTypes _ TClosure {} = GT
|
|
||||||
compareTypes TPath TPath = EQ
|
|
||||||
compareTypes TPath _ = LT
|
|
||||||
compareTypes _ TPath = GT
|
|
||||||
compareTypes (TBuiltin _ _) (TBuiltin _ _) = EQ
|
|
||||||
|
|
||||||
data NSymbolicF r
|
|
||||||
= NAny
|
|
||||||
| NMany [r]
|
|
||||||
deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
|
|
||||||
|
|
||||||
newtype SThunk m = SThunk { getSThunk :: Thunk m (Symbolic m) }
|
|
||||||
|
|
||||||
sthunk :: MonadVar m => m (Symbolic m) -> m (SThunk m)
|
|
||||||
sthunk = fmap coerce . buildThunk
|
|
||||||
|
|
||||||
sforce :: (Framed e m, MonadFile m, MonadVar m)
|
|
||||||
=> SThunk m -> (Symbolic m -> m r) -> m r
|
|
||||||
sforce = forceThunk . coerce
|
|
||||||
|
|
||||||
svalueThunk :: forall m. Symbolic m -> SThunk m
|
|
||||||
svalueThunk = coerce . valueRef @_ @m
|
|
||||||
|
|
||||||
type Symbolic m = Var m (NSymbolicF (NTypeF m (SThunk m)))
|
|
||||||
|
|
||||||
everyPossible :: MonadVar m => m (Symbolic m)
|
|
||||||
everyPossible = packSymbolic NAny
|
|
||||||
|
|
||||||
mkSymbolic :: MonadVar m => [NTypeF m (SThunk m)] -> m (Symbolic m)
|
|
||||||
mkSymbolic xs = packSymbolic (NMany xs)
|
|
||||||
|
|
||||||
packSymbolic :: MonadVar m
|
|
||||||
=> NSymbolicF (NTypeF m (SThunk m)) -> m (Symbolic m)
|
|
||||||
packSymbolic = newVar
|
|
||||||
|
|
||||||
unpackSymbolic :: MonadVar m
|
|
||||||
=> Symbolic m -> m (NSymbolicF (NTypeF m (SThunk m)))
|
|
||||||
unpackSymbolic = readVar
|
|
||||||
|
|
||||||
renderSymbolic :: MonadLint e m
|
|
||||||
=> Symbolic m -> m String
|
|
||||||
renderSymbolic = unpackSymbolic >=> \case
|
|
||||||
NAny -> return "<any>"
|
|
||||||
NMany xs -> fmap (intercalate ", ") $ forM xs $ \case
|
|
||||||
TConstant ys -> fmap (intercalate ", ") $ forM ys $ \case
|
|
||||||
TInt -> return "int"
|
|
||||||
TFloat -> return "float"
|
|
||||||
TBool -> return "bool"
|
|
||||||
TNull -> return "null"
|
|
||||||
TUri -> return "uri"
|
|
||||||
TStr -> return "string"
|
|
||||||
TList r -> do
|
|
||||||
x <- sforce r renderSymbolic
|
|
||||||
return $ "[" ++ x ++ "]"
|
|
||||||
TSet Nothing -> return "<any set>"
|
|
||||||
TSet (Just s) -> do
|
|
||||||
x <- traverse (`sforce` renderSymbolic) s
|
|
||||||
return $ "{" ++ show x ++ "}"
|
|
||||||
f@(TClosure s p _) -> do
|
|
||||||
(args, sym) <-
|
|
||||||
lintApp (NAbs (void p) ()) (mkSymbolic [f]) everyPossible
|
|
||||||
args' <- traverse renderSymbolic args
|
|
||||||
sym' <- renderSymbolic sym
|
|
||||||
return $ "(" ++ show s ++ " over " ++ show args'
|
|
||||||
++ " -> " ++ sym' ++ ")"
|
|
||||||
TPath -> return "path"
|
|
||||||
TBuiltin _n _f -> return "<builtin function>"
|
|
||||||
|
|
||||||
-- This function is order and uniqueness preserving (of types).
|
|
||||||
merge :: forall e m. MonadLint e m
|
|
||||||
=> NExprF () -> [NTypeF m (SThunk m)] -> [NTypeF m (SThunk m)]
|
|
||||||
-> m [NTypeF m (SThunk m)]
|
|
||||||
merge context = go
|
|
||||||
where
|
|
||||||
go :: [NTypeF m (SThunk m)] -> [NTypeF m (SThunk m)]
|
|
||||||
-> m [NTypeF m (SThunk m)]
|
|
||||||
go [] _ = return []
|
|
||||||
go _ [] = return []
|
|
||||||
go (x:xs) (y:ys) = case (x, y) of
|
|
||||||
(TStr, TStr) -> (TStr :) <$> go xs ys
|
|
||||||
(TPath, TPath) -> (TPath :) <$> go xs ys
|
|
||||||
(TConstant ls, TConstant rs) ->
|
|
||||||
(TConstant (ls `intersect` rs) :) <$> go xs ys
|
|
||||||
(TList l, TList r) -> sforce l $ \l' -> sforce r $ \r' -> do
|
|
||||||
m <- sthunk $ unify context l' r'
|
|
||||||
(TList m :) <$> go xs ys
|
|
||||||
(TSet x, TSet Nothing) -> (TSet x :) <$> go xs ys
|
|
||||||
(TSet Nothing, TSet x) -> (TSet x :) <$> go xs ys
|
|
||||||
(TSet (Just l), TSet (Just r)) -> do
|
|
||||||
m <- sequenceA $ M.intersectionWith
|
|
||||||
(\i j -> i >>= \i' -> j >>= \j' ->
|
|
||||||
sforce i' $ \i'' -> sforce j' $ \j'' ->
|
|
||||||
sthunk $ unify context i'' j'')
|
|
||||||
(return <$> l) (return <$> r)
|
|
||||||
if M.null m
|
|
||||||
then go xs ys
|
|
||||||
else (TSet (Just m) :) <$> go xs ys
|
|
||||||
(TClosure {}, TClosure {}) ->
|
|
||||||
throwError "Cannot unify functions"
|
|
||||||
(TBuiltin _ _, TBuiltin _ _) ->
|
|
||||||
throwError "Cannot unify builtin functions"
|
|
||||||
_ | compareTypes x y == LT -> go xs (y:ys)
|
|
||||||
| compareTypes x y == GT -> go (x:xs) ys
|
|
||||||
| otherwise -> error "impossible"
|
|
||||||
|
|
||||||
{-
|
|
||||||
mergeFunctions pl nl fl pr fr xs ys = do
|
|
||||||
m <- sequenceA $ M.intersectionWith
|
|
||||||
(\i j -> i >>= \i' -> j >>= \j' -> case (i', j') of
|
|
||||||
(Nothing, Nothing) -> return $ Just Nothing
|
|
||||||
(_, Nothing) -> return Nothing
|
|
||||||
(Nothing, _) -> return Nothing
|
|
||||||
(Just i'', Just j'') ->
|
|
||||||
Just . Just <$> unify context i'' j'')
|
|
||||||
(return <$> pl) (return <$> pr)
|
|
||||||
let Just m' = sequenceA $ M.filter isJust m
|
|
||||||
if M.null m'
|
|
||||||
then go xs ys
|
|
||||||
else do
|
|
||||||
g <- unify context fl fr
|
|
||||||
(TClosure (ParamSet m' False nl) g :)
|
|
||||||
<$> go xs ys
|
|
||||||
-}
|
|
||||||
|
|
||||||
type MonadLint e m =
|
|
||||||
( Scoped e (SThunk m) m
|
|
||||||
, Framed e m
|
|
||||||
, MonadExpr (SThunk m) (Symbolic m) m
|
|
||||||
, MonadFix m
|
|
||||||
, MonadFile m
|
|
||||||
, MonadVar m
|
|
||||||
)
|
|
||||||
|
|
||||||
-- | unify raises an error if the result is would be 'NMany []'.
|
|
||||||
unify :: MonadLint e m
|
|
||||||
=> NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
|
|
||||||
unify context x y = do
|
|
||||||
x' <- readVar x
|
|
||||||
y' <- readVar y
|
|
||||||
case (x', y') of
|
|
||||||
(NAny, _) -> do
|
|
||||||
writeVar x y'
|
|
||||||
return y
|
|
||||||
(_, NAny) -> do
|
|
||||||
writeVar y x'
|
|
||||||
return x
|
|
||||||
(NMany xs, NMany ys) -> do
|
|
||||||
m <- merge context xs ys
|
|
||||||
if null m
|
|
||||||
then do
|
|
||||||
x' <- renderSymbolic x
|
|
||||||
y' <- renderSymbolic y
|
|
||||||
throwError $ "Cannot unify "
|
|
||||||
++ show x' ++ " with " ++ show y'
|
|
||||||
++ " in context: " ++ show context
|
|
||||||
else do
|
|
||||||
writeVar x (NMany m)
|
|
||||||
writeVar y (NMany m)
|
|
||||||
packSymbolic (NMany m)
|
|
||||||
|
|
||||||
lintExpr :: MonadLint e m
|
|
||||||
=> NExpr -> m (Symbolic m)
|
|
||||||
lintExpr = cata lint
|
|
||||||
|
|
||||||
lint :: forall e m. MonadLint e m
|
|
||||||
=> NExprF (m (Symbolic m)) -> m (Symbolic m)
|
|
||||||
|
|
||||||
lint (NSym var) = do
|
|
||||||
mres <- lookupVar var
|
|
||||||
case mres of
|
|
||||||
Nothing -> throwError $ "Undefined variable: " ++ show var
|
|
||||||
Just v -> sforce v pure
|
|
||||||
|
|
||||||
lint (NConstant c) = mkSymbolic [TConstant [t]]
|
|
||||||
where
|
|
||||||
t = case c of
|
|
||||||
NInt _ -> TInt
|
|
||||||
NFloat _ -> TFloat
|
|
||||||
NBool _ -> TBool
|
|
||||||
NNull -> TNull
|
|
||||||
NUri _ -> TUri
|
|
||||||
|
|
||||||
lint (NStr _) = mkSymbolic [TStr]
|
|
||||||
lint (NLiteralPath _) = mkSymbolic [TPath]
|
|
||||||
lint (NEnvPath _) = mkSymbolic [TPath]
|
|
||||||
|
|
||||||
lint e@(NUnary _op arg) =
|
|
||||||
join $ unify (void e) <$> arg <*> mkSymbolic [TConstant [TInt, TBool]]
|
|
||||||
|
|
||||||
lint e@(NBinary op larg rarg) = do
|
|
||||||
lsym <- larg
|
|
||||||
rsym <- rarg
|
|
||||||
y <- sthunk everyPossible
|
|
||||||
case op of
|
|
||||||
NEq -> check lsym rsym [ TConstant [TInt, TBool, TNull, TUri]
|
|
||||||
, TStr
|
|
||||||
, TList y ]
|
|
||||||
NNEq -> check lsym rsym [ TConstant [TInt, TBool, TNull, TUri]
|
|
||||||
, TStr
|
|
||||||
, TList y ]
|
|
||||||
|
|
||||||
NLt -> check lsym rsym [ TConstant [TInt, TBool, TNull, TUri] ]
|
|
||||||
NLte -> check lsym rsym [ TConstant [TInt, TBool, TNull, TUri] ]
|
|
||||||
NGt -> check lsym rsym [ TConstant [TInt, TBool, TNull, TUri] ]
|
|
||||||
NGte -> check lsym rsym [ TConstant [TInt, TBool, TNull, TUri] ]
|
|
||||||
|
|
||||||
NAnd -> check lsym rsym [ TConstant [TBool] ]
|
|
||||||
NOr -> check lsym rsym [ TConstant [TBool] ]
|
|
||||||
NImpl -> check lsym rsym [ TConstant [TBool] ]
|
|
||||||
|
|
||||||
-- jww (2018-04-01): NYI: Allow Path + Str
|
|
||||||
NPlus -> check lsym rsym [ TConstant [TInt], TStr, TPath ]
|
|
||||||
NMinus -> check lsym rsym [ TConstant [TInt] ]
|
|
||||||
NMult -> check lsym rsym [ TConstant [TInt] ]
|
|
||||||
NDiv -> check lsym rsym [ TConstant [TInt] ]
|
|
||||||
|
|
||||||
NUpdate -> check lsym rsym [ TSet Nothing ]
|
|
||||||
|
|
||||||
NConcat -> check lsym rsym [ TList y ]
|
|
||||||
where
|
|
||||||
check lsym rsym xs = do
|
|
||||||
m <- mkSymbolic xs
|
|
||||||
_ <- unify (void e) lsym m
|
|
||||||
_ <- unify (void e) rsym m
|
|
||||||
unify (void e) lsym rsym
|
|
||||||
|
|
||||||
lint (NSelect aset attr alternative) = do
|
|
||||||
aset' <- unpackSymbolic =<< aset
|
|
||||||
ks <- evalSelector True attr
|
|
||||||
mres <- extract aset' ks
|
|
||||||
case mres of
|
|
||||||
Just v -> return v
|
|
||||||
Nothing -> fromMaybe err alternative
|
|
||||||
where
|
|
||||||
err = throwError $ "could not look up attribute "
|
|
||||||
++ intercalate "." (map show ks)
|
|
||||||
++ " in " ++ show (void aset')
|
|
||||||
where
|
|
||||||
extract NAny (_:_) = Just <$> everyPossible
|
|
||||||
extract (NMany [TSet Nothing]) (_:_ks) =
|
|
||||||
error "NYI: Selection in unknown set"
|
|
||||||
extract (NMany [TSet (Just s)]) (k:ks) = case M.lookup k s of
|
|
||||||
Just v -> sforce v $ unpackSymbolic >=> extract ?? ks
|
|
||||||
Nothing -> return Nothing
|
|
||||||
extract _ (_:_) = return Nothing
|
|
||||||
extract v [] = Just <$> packSymbolic v
|
|
||||||
|
|
||||||
lint (NHasAttr aset attr) = aset >>= unpackSymbolic >>= \case
|
|
||||||
NMany [TSet _] -> evalSelector True attr >>= \case
|
|
||||||
[_] -> mkSymbolic [TConstant [TBool]]
|
|
||||||
_ -> -- jww (2018-04-05): Need to repeat the logic above
|
|
||||||
throwError $ "attr name argument to hasAttr"
|
|
||||||
++ " is not a single-part name"
|
|
||||||
_ -> throwError "argument to hasAttr has wrong type"
|
|
||||||
|
|
||||||
lint e@(NList l) = do
|
|
||||||
scope <- currentScopes
|
|
||||||
y <- everyPossible
|
|
||||||
traverse (withScopes @(SThunk m) scope) l
|
|
||||||
>>= foldM (unify (void e)) y
|
|
||||||
>>= (\t -> mkSymbolic [TList (svalueThunk t)])
|
|
||||||
|
|
||||||
lint (NSet binds) = do
|
|
||||||
(s, _) <- evalBinds True False binds
|
|
||||||
mkSymbolic [TSet (Just s)]
|
|
||||||
|
|
||||||
lint (NRecSet binds) = do
|
|
||||||
(s, _) <- evalBinds True True binds
|
|
||||||
mkSymbolic [TSet (Just s)]
|
|
||||||
|
|
||||||
lint (NLet binds body) = do
|
|
||||||
(s, _) <- evalBinds True True binds
|
|
||||||
pushScope s body
|
|
||||||
|
|
||||||
lint e@(NIf cond t f) = do
|
|
||||||
_ <- join $ unify (void e) <$> cond <*> mkSymbolic [TConstant [TBool]]
|
|
||||||
join $ unify (void e) <$> t <*> f
|
|
||||||
|
|
||||||
lint (NWith scope body) = do
|
|
||||||
s <- sthunk scope
|
|
||||||
pushWeakScope ?? body $ sforce s $ unpackSymbolic >=> \case
|
|
||||||
NMany [TSet (Just s')] -> return s'
|
|
||||||
NMany [TSet Nothing] -> error "with unknown set"
|
|
||||||
_ -> throwError "scope must be a set in with statement"
|
|
||||||
|
|
||||||
lint e@(NAssert cond body) = do
|
|
||||||
_ <- join $ unify (void e) <$> cond <*> mkSymbolic [TConstant [TBool]]
|
|
||||||
body
|
|
||||||
|
|
||||||
lint e@(NApp fun arg) = snd <$> lintApp (void e) fun arg
|
|
||||||
|
|
||||||
lint (NAbs params body) = do
|
|
||||||
scope <- currentScopes @_ @(SThunk m)
|
|
||||||
mkSymbolic [TClosure scope (sthunk <$> params) (sthunk body)]
|
|
||||||
|
|
||||||
infixl 1 `lintApp`
|
|
||||||
lintApp :: forall e m. MonadLint e m
|
|
||||||
=> NExprF () -> m (Symbolic m) -> m (Symbolic m)
|
|
||||||
-> m (HashMap Text (Symbolic m), Symbolic m)
|
|
||||||
lintApp context fun arg = fun >>= unpackSymbolic >>= \case
|
|
||||||
NAny -> throwError "Cannot apply something not known to be a function"
|
|
||||||
NMany xs -> do
|
|
||||||
(args:_, ys) <- fmap unzip $ forM xs $ \case
|
|
||||||
TClosure scope params f -> arg >>= unpackSymbolic >>= \case
|
|
||||||
NAny -> do
|
|
||||||
pset <- case params of
|
|
||||||
Param name ->
|
|
||||||
M.singleton name <$> everyPossible
|
|
||||||
ParamSet _s _ (Just _) -> error "NYI"
|
|
||||||
ParamSet s _ Nothing ->
|
|
||||||
traverse (const everyPossible) (OM.toHashMap s)
|
|
||||||
pset' <- traverse (sthunk . pure) pset
|
|
||||||
arg' <- sthunk $ mkSymbolic [TSet (Just pset')]
|
|
||||||
args <- buildArgument params arg'
|
|
||||||
res <- withScopes @(SThunk m) scope $
|
|
||||||
pushScope args $ sforce ?? pure =<< f
|
|
||||||
return (pset, res)
|
|
||||||
|
|
||||||
NMany [TSet (Just _)] -> do
|
|
||||||
args <- buildArgument params =<< sthunk arg
|
|
||||||
res <- clearScopes @(SThunk m) $
|
|
||||||
pushScope args $ sforce ?? pure =<< f
|
|
||||||
args' <- traverse (sforce ?? pure) args
|
|
||||||
return (args', res)
|
|
||||||
|
|
||||||
NMany _ -> throwError "NYI: lintApp NMany not set"
|
|
||||||
TBuiltin _ _f -> throwError "NYI: lintApp builtin"
|
|
||||||
TSet _m -> throwError "NYI: lintApp Set"
|
|
||||||
_x -> throwError "Attempt to call non-function"
|
|
||||||
|
|
||||||
y <- everyPossible
|
|
||||||
(args,) <$> foldM (unify context) y ys
|
|
46
Nix/Monad.hs
46
Nix/Monad.hs
|
@ -1,46 +0,0 @@
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE ConstraintKinds #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
|
|
||||||
module Nix.Monad where
|
|
||||||
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Nix.Value
|
|
||||||
import System.Posix.Files
|
|
||||||
|
|
||||||
-- | A path into the nix store
|
|
||||||
newtype StorePath = StorePath { unStorePath :: FilePath }
|
|
||||||
|
|
||||||
class Monad m => MonadNix m where
|
|
||||||
-- | Import a path into the nix store, and return the resulting path
|
|
||||||
addPath :: FilePath -> m StorePath
|
|
||||||
|
|
||||||
-- | Determine the absolute path of relative path in the current context
|
|
||||||
makeAbsolutePath :: FilePath -> m FilePath
|
|
||||||
|
|
||||||
pathExists :: FilePath -> m Bool
|
|
||||||
importFile :: ValueSet m -> FilePath -> m (NValue m)
|
|
||||||
getEnvVar :: String -> m (Maybe String)
|
|
||||||
getCurrentSystemOS :: m Text
|
|
||||||
getCurrentSystemArch :: m Text
|
|
||||||
|
|
||||||
listDirectory :: FilePath -> m [FilePath]
|
|
||||||
getSymbolicLinkStatus :: FilePath -> m FileStatus
|
|
||||||
|
|
||||||
builtin :: MonadNix m => String -> (NThunk m -> m (NValue m)) -> m (NValue m)
|
|
||||||
builtin name f = return $ NVBuiltin name f
|
|
||||||
|
|
||||||
builtin2 :: MonadNix m
|
|
||||||
=> String -> (NThunk m -> NThunk m -> m (NValue m)) -> m (NValue m)
|
|
||||||
builtin2 name f = builtin name (builtin name . f)
|
|
||||||
|
|
||||||
builtin3 :: MonadNix m
|
|
||||||
=> String -> (NThunk m -> NThunk m -> NThunk m -> m (NValue m))
|
|
||||||
-> m (NValue m)
|
|
||||||
builtin3 name f =
|
|
||||||
builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c
|
|
|
@ -1,175 +0,0 @@
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE PartialTypeSignatures #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE TupleSections #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
|
|
||||||
{-# OPTIONS_GHC -Wno-missing-signatures #-}
|
|
||||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
|
||||||
|
|
||||||
module Nix.Monad.Instance where
|
|
||||||
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.Fix
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Control.Monad.Reader (MonadReader)
|
|
||||||
import Control.Monad.Trans.Reader
|
|
||||||
import qualified Data.ByteString as BS
|
|
||||||
import Data.Fix
|
|
||||||
import qualified Data.HashMap.Lazy as M
|
|
||||||
import Data.IORef
|
|
||||||
import Data.List
|
|
||||||
import Data.List.Split
|
|
||||||
import Data.Text (Text)
|
|
||||||
import qualified Data.Text as Text
|
|
||||||
import Nix.Atoms
|
|
||||||
import Nix.Eval
|
|
||||||
import Nix.Monad
|
|
||||||
import Nix.Parser
|
|
||||||
import Nix.Scope
|
|
||||||
import Nix.Stack
|
|
||||||
import Nix.Thunk
|
|
||||||
import Nix.Utils
|
|
||||||
import Nix.Value
|
|
||||||
import System.Directory
|
|
||||||
import System.Environment
|
|
||||||
import System.Exit (ExitCode (ExitSuccess))
|
|
||||||
import System.FilePath
|
|
||||||
import qualified System.Info
|
|
||||||
import System.Posix.Files
|
|
||||||
import System.Process (readProcessWithExitCode)
|
|
||||||
|
|
||||||
data Context m v = Context
|
|
||||||
{ scopes :: Scopes m v
|
|
||||||
, frames :: Frames
|
|
||||||
}
|
|
||||||
|
|
||||||
newtype Lazy m a = Lazy
|
|
||||||
{ runLazy :: ReaderT (Context (Lazy m) (NThunk (Lazy m))) m a }
|
|
||||||
deriving (Functor, Applicative, Monad, MonadFix, MonadIO,
|
|
||||||
MonadReader (Context (Lazy m) (NThunk (Lazy m))))
|
|
||||||
|
|
||||||
instance Has (Context m v) (Scopes m v) where
|
|
||||||
hasLens f (Context x y) = flip Context y <$> f x
|
|
||||||
|
|
||||||
instance Has (Context m v) Frames where
|
|
||||||
hasLens f (Context x y) = Context x <$> f y
|
|
||||||
|
|
||||||
-- | Incorrectly normalize paths by rewriting patterns like @a/b/..@ to @a@.
|
|
||||||
-- This is incorrect on POSIX systems, because if @b@ is a symlink, its parent
|
|
||||||
-- may be a different directory from @a@. See the discussion at
|
|
||||||
-- https://hackage.haskell.org/package/directory-1.3.1.5/docs/System-Directory.html#v:canonicalizePath
|
|
||||||
removeDotDotIndirections :: FilePath -> FilePath
|
|
||||||
removeDotDotIndirections = intercalate "/" . go [] . splitOn "/"
|
|
||||||
where go s [] = reverse s
|
|
||||||
go (_:s) ("..":rest) = go s rest
|
|
||||||
go s (this:rest) = go (this:s) rest
|
|
||||||
|
|
||||||
instance (MonadFix m, MonadNix (Lazy m), MonadIO m)
|
|
||||||
=> MonadExpr (NThunk (Lazy m)) (NValue (Lazy m)) (Lazy m) where
|
|
||||||
embedSet = return . flip NVSet M.empty
|
|
||||||
projectSet = \case
|
|
||||||
NVSet s _ -> return $ Just s
|
|
||||||
_ -> return Nothing
|
|
||||||
projectSetWithPos = \case
|
|
||||||
NVSet s p -> return $ Just (s, p)
|
|
||||||
_ -> return Nothing
|
|
||||||
|
|
||||||
type MText (Lazy m) = (Text, DList Text)
|
|
||||||
|
|
||||||
wrapText = return . (, mempty)
|
|
||||||
unwrapText = return . fst
|
|
||||||
|
|
||||||
embedText = return . uncurry NVStr
|
|
||||||
projectText = \case
|
|
||||||
NVConstant NNull -> return $ Just Nothing
|
|
||||||
v -> fmap (Just . Just) . valueText True =<< normalForm v
|
|
||||||
|
|
||||||
instance MonadIO m => MonadVar (Lazy m) where
|
|
||||||
type Var (Lazy m) = IORef
|
|
||||||
|
|
||||||
newVar = liftIO . newIORef
|
|
||||||
readVar = liftIO . readIORef
|
|
||||||
writeVar = (liftIO .) . writeIORef
|
|
||||||
atomicModifyVar = (liftIO .) . atomicModifyIORef
|
|
||||||
|
|
||||||
instance MonadIO m => MonadFile (Lazy m) where
|
|
||||||
readFile = liftIO . BS.readFile
|
|
||||||
|
|
||||||
instance (MonadFix m, MonadIO m) => MonadNix (Lazy m) where
|
|
||||||
addPath path = liftIO $ do
|
|
||||||
(exitCode, out, _) <-
|
|
||||||
readProcessWithExitCode "nix-store" ["--add", path] ""
|
|
||||||
case exitCode of
|
|
||||||
ExitSuccess -> do
|
|
||||||
let dropTrailingLinefeed p = take (length p - 1) p
|
|
||||||
return $ StorePath $ dropTrailingLinefeed out
|
|
||||||
_ -> error $ "No such file or directory: " ++ show path
|
|
||||||
|
|
||||||
makeAbsolutePath origPath = do
|
|
||||||
absPath <- if isAbsolute origPath then pure origPath else do
|
|
||||||
cwd <- do
|
|
||||||
mres <- lookupVar @_ @(NThunk (Lazy m)) "__cur_file"
|
|
||||||
case mres of
|
|
||||||
Nothing -> liftIO getCurrentDirectory
|
|
||||||
Just v -> force v $ \case
|
|
||||||
NVLiteralPath s -> return $ takeDirectory s
|
|
||||||
v -> throwError $ "when resolving relative path,"
|
|
||||||
++ " __cur_file is in scope,"
|
|
||||||
++ " but is not a path; it is: "
|
|
||||||
++ show (void v)
|
|
||||||
pure $ cwd </> origPath
|
|
||||||
liftIO $ removeDotDotIndirections <$> canonicalizePath absPath
|
|
||||||
|
|
||||||
pathExists = liftIO . fileExist
|
|
||||||
|
|
||||||
-- jww (2018-03-29): Cache which files have been read in.
|
|
||||||
importFile scope path = do
|
|
||||||
mres <- lookupVar @(Context (Lazy m) (NThunk (Lazy m)))
|
|
||||||
"__cur_file"
|
|
||||||
path' <- case mres of
|
|
||||||
Nothing -> do
|
|
||||||
traceM "No known current directory"
|
|
||||||
return path
|
|
||||||
Just p -> force p $ normalForm >=> \case
|
|
||||||
Fix (NVLiteralPath p') -> do
|
|
||||||
traceM $ "Current file being evaluated is: "
|
|
||||||
++ show p'
|
|
||||||
return $ takeDirectory p' </> path
|
|
||||||
x -> error $ "How can the current directory be: " ++ show x
|
|
||||||
|
|
||||||
traceM $ "Importing file " ++ path'
|
|
||||||
|
|
||||||
withStringContext ("While importing file " ++ show path') $ do
|
|
||||||
eres <- Lazy $ parseNixFileLoc path'
|
|
||||||
case eres of
|
|
||||||
Failure err -> error $ "Parse failed: " ++ show err
|
|
||||||
Success expr -> do
|
|
||||||
let ref = valueThunk @(Lazy m) (NVLiteralPath path')
|
|
||||||
-- Use this cookie so that when we evaluate the next
|
|
||||||
-- import, we'll remember which directory its containing
|
|
||||||
-- file was in.
|
|
||||||
pushScope (M.singleton "__cur_file" ref)
|
|
||||||
(pushScope scope (framedEvalExpr eval expr))
|
|
||||||
|
|
||||||
getEnvVar = liftIO . lookupEnv
|
|
||||||
|
|
||||||
getCurrentSystemOS = return $ Text.pack System.Info.os
|
|
||||||
|
|
||||||
-- Invert the conversion done by GHC_CONVERT_CPU in GHC's aclocal.m4
|
|
||||||
getCurrentSystemArch = return $ Text.pack $ case System.Info.arch of
|
|
||||||
"i386" -> "i686"
|
|
||||||
arch -> arch
|
|
||||||
|
|
||||||
listDirectory = liftIO . System.Directory.listDirectory
|
|
||||||
getSymbolicLinkStatus = liftIO . System.Posix.Files.getSymbolicLinkStatus
|
|
||||||
|
|
||||||
runLazyM :: MonadIO m => Lazy m a -> m a
|
|
||||||
runLazyM = flip runReaderT (Context emptyScopes []) . runLazy
|
|
319
Nix/Parser.hs
319
Nix/Parser.hs
|
@ -1,319 +0,0 @@
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
|
||||||
|
|
||||||
module Nix.Parser (
|
|
||||||
parseNixFile,
|
|
||||||
parseNixFileLoc,
|
|
||||||
parseNixString,
|
|
||||||
parseNixStringLoc,
|
|
||||||
parseNixText,
|
|
||||||
parseNixTextLoc,
|
|
||||||
Result(..)
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Applicative
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Data.Foldable hiding (concat)
|
|
||||||
import Data.Functor
|
|
||||||
import qualified Data.HashMap.Strict.InsOrd as M
|
|
||||||
import Data.Text hiding (map, foldl', concat)
|
|
||||||
import Nix.Expr hiding (($>))
|
|
||||||
import Nix.Parser.Library
|
|
||||||
import Nix.Parser.Operators
|
|
||||||
import Nix.StringOperations
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
annotateLocation :: Parser a -> Parser (Ann SrcSpan a)
|
|
||||||
annotateLocation p = do
|
|
||||||
begin <- position
|
|
||||||
res <- p
|
|
||||||
end <- position
|
|
||||||
let span = SrcSpan begin end
|
|
||||||
pure $ Ann span res
|
|
||||||
|
|
||||||
annotateLocation1 :: Parser (NExprF NExprLoc) -> Parser NExprLoc
|
|
||||||
annotateLocation1 = fmap annToAnnF . annotateLocation
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
nixExpr :: Parser NExpr
|
|
||||||
nixExpr = stripAnnotation <$> nixExprLoc
|
|
||||||
|
|
||||||
-- | The lexer for this parser is defined in 'Nix.Parser.Library'.
|
|
||||||
nixExprLoc :: Parser NExprLoc
|
|
||||||
nixExprLoc =
|
|
||||||
whiteSpace *> (nixToplevelForm <|> foldl' makeParser nixTerm nixOperators)
|
|
||||||
where
|
|
||||||
makeParser :: Parser NExprLoc -> Either NSpecialOp NOperatorDef
|
|
||||||
-> Parser NExprLoc
|
|
||||||
makeParser term (Left NSelectOp) = nixSelect term
|
|
||||||
makeParser term (Left NAppOp) = chainl1 term (pure nApp)
|
|
||||||
makeParser term (Left NHasAttrOp) = nixHasAttr term
|
|
||||||
makeParser term (Right (NUnaryDef name op)) =
|
|
||||||
build <$> many (annotateLocation (void $ symbol name)) <*> term
|
|
||||||
where
|
|
||||||
build :: [Ann SrcSpan ()] -> NExprLoc -> NExprLoc
|
|
||||||
build = flip $ foldl' (\t' (Ann s ()) -> nUnary (Ann s op) t')
|
|
||||||
|
|
||||||
makeParser term (Right (NBinaryDef assoc ops)) = case assoc of
|
|
||||||
NAssocLeft -> chainl1 term op
|
|
||||||
NAssocRight -> chainr1 term op
|
|
||||||
NAssocNone -> term <**> (flip <$> op <*> term <|> pure id)
|
|
||||||
where
|
|
||||||
op :: Parser (NExprLoc -> NExprLoc -> NExprLoc)
|
|
||||||
op = choice . map (\(n,o) -> (\(Ann a ()) -> nBinary (Ann a o))
|
|
||||||
<$> annotateLocation (reservedOp n)) $ ops
|
|
||||||
|
|
||||||
antiStart :: Parser String
|
|
||||||
antiStart = try (string "${") <?> show ("${" :: String)
|
|
||||||
|
|
||||||
nixAntiquoted :: Parser a -> Parser (Antiquoted a NExprLoc)
|
|
||||||
nixAntiquoted p = Antiquoted <$> (antiStart *> nixExprLoc <* symbolic '}') <|> Plain <$> p
|
|
||||||
|
|
||||||
selDot :: Parser ()
|
|
||||||
selDot = try (char '.' *> notFollowedBy (("path" :: String) <$ nixPath)) *> whiteSpace
|
|
||||||
<?> "."
|
|
||||||
|
|
||||||
nixSelector :: Parser (Ann SrcSpan (NAttrPath NExprLoc))
|
|
||||||
nixSelector = annotateLocation $ keyName `sepBy1` selDot
|
|
||||||
|
|
||||||
nixSelect :: Parser NExprLoc -> Parser NExprLoc
|
|
||||||
nixSelect term = build
|
|
||||||
<$> term
|
|
||||||
<*> optional ((,) <$> (selDot *> nixSelector) <*> optional (reserved "or" *> nixTerm))
|
|
||||||
where
|
|
||||||
build :: NExprLoc -> Maybe (Ann SrcSpan (NAttrPath NExprLoc), Maybe NExprLoc) -> NExprLoc
|
|
||||||
build t Nothing = t
|
|
||||||
build t (Just (s,o)) = nSelectLoc t s o
|
|
||||||
|
|
||||||
nixHasAttr :: Parser NExprLoc -> Parser NExprLoc
|
|
||||||
nixHasAttr term = build <$> term <*> optional (reservedOp "?" *> nixSelector) where
|
|
||||||
build :: NExprLoc -> Maybe (Ann SrcSpan (NAttrPath NExprLoc)) -> NExprLoc
|
|
||||||
build t Nothing = t
|
|
||||||
build t (Just s) = nHasAttr t s
|
|
||||||
|
|
||||||
-- | A self-contained unit.
|
|
||||||
nixTerm :: Parser NExprLoc
|
|
||||||
nixTerm = nixSelect $ choice
|
|
||||||
[ nixPath, nixSPath, nixFloat, nixInt, nixBool, nixNull, nixParens, nixList, nixUri
|
|
||||||
, nixStringExpr, nixSet, nixSym ]
|
|
||||||
|
|
||||||
nixToplevelForm :: Parser NExprLoc
|
|
||||||
nixToplevelForm = choice [nixLambda, nixLet, nixIf, nixAssert, nixWith]
|
|
||||||
|
|
||||||
nixSym :: Parser NExprLoc
|
|
||||||
nixSym = annotateLocation1 $ mkSymF <$> identifier
|
|
||||||
|
|
||||||
nixInt :: Parser NExprLoc
|
|
||||||
nixInt = annotateLocation1 $ mkIntF <$> token decimal <?> "integer"
|
|
||||||
|
|
||||||
nixFloat :: Parser NExprLoc
|
|
||||||
nixFloat = annotateLocation1 $ try (mkFloatF . realToFrac <$> token double) <?> "float"
|
|
||||||
|
|
||||||
nixBool :: Parser NExprLoc
|
|
||||||
nixBool = annotateLocation1 $ try (true <|> false) <?> "bool" where
|
|
||||||
true = mkBoolF True <$ reserved "true"
|
|
||||||
false = mkBoolF False <$ reserved "false"
|
|
||||||
|
|
||||||
nixNull :: Parser NExprLoc
|
|
||||||
nixNull = annotateLocation1 $ mkNullF <$ try (reserved "null") <?> "null"
|
|
||||||
|
|
||||||
nixParens :: Parser NExprLoc
|
|
||||||
nixParens = parens nixExprLoc <?> "parens"
|
|
||||||
|
|
||||||
nixList :: Parser NExprLoc
|
|
||||||
nixList = annotateLocation1 $ brackets (NList <$> many nixTerm) <?> "list"
|
|
||||||
|
|
||||||
pathChars :: String
|
|
||||||
pathChars = ['A'..'Z'] ++ ['a'..'z'] ++ "._-+" ++ ['0'..'9']
|
|
||||||
|
|
||||||
slash :: Parser Char
|
|
||||||
slash = try (char '/' <* notFollowedBy (void (char '/') <|>
|
|
||||||
void (char '*') <|>
|
|
||||||
someSpace))
|
|
||||||
<?> "slash"
|
|
||||||
|
|
||||||
-- | A path surrounded by angle brackets, indicating that it should be
|
|
||||||
-- looked up in the NIX_PATH environment variable at evaluation.
|
|
||||||
nixSPath :: Parser NExprLoc
|
|
||||||
nixSPath = annotateLocation1 $ mkPathF True <$> try (char '<' *> some (oneOf pathChars <|> slash) <* symbolic '>')
|
|
||||||
<?> "spath"
|
|
||||||
|
|
||||||
nixPath :: Parser NExprLoc
|
|
||||||
nixPath = annotateLocation1 $ token $ fmap (mkPathF False) $ ((++)
|
|
||||||
<$> (try ((++) <$> many (oneOf pathChars) <*> fmap (:[]) slash) <?> "path")
|
|
||||||
<*> fmap concat
|
|
||||||
( some (some (oneOf pathChars)
|
|
||||||
<|> liftA2 (:) slash (some (oneOf pathChars)))
|
|
||||||
)
|
|
||||||
)
|
|
||||||
<?> "path"
|
|
||||||
|
|
||||||
nixLet :: Parser NExprLoc
|
|
||||||
nixLet = annotateLocation1 $ reserved "let"
|
|
||||||
*> whiteSpace
|
|
||||||
*> (letBody <|> letBinders)
|
|
||||||
<?> "let block"
|
|
||||||
where
|
|
||||||
letBinders = NLet
|
|
||||||
<$> nixBinders
|
|
||||||
<*> (whiteSpace *> reserved "in" *> nixExprLoc)
|
|
||||||
-- Let expressions `let {..., body = ...}' are just desugared
|
|
||||||
-- into `(rec {..., body = ...}).body'.
|
|
||||||
letBody = (\x pos -> NSelect x [StaticKey "body" (Just pos)] Nothing)
|
|
||||||
<$> aset <*> position
|
|
||||||
aset = annotateLocation1 $ NRecSet <$> braces nixBinders
|
|
||||||
|
|
||||||
|
|
||||||
nixIf :: Parser NExprLoc
|
|
||||||
nixIf = annotateLocation1 $ NIf
|
|
||||||
<$> (reserved "if" *> nixExprLoc)
|
|
||||||
<*> (whiteSpace *> reserved "then" *> nixExprLoc)
|
|
||||||
<*> (whiteSpace *> reserved "else" *> nixExprLoc)
|
|
||||||
<?> "if"
|
|
||||||
|
|
||||||
nixAssert :: Parser NExprLoc
|
|
||||||
nixAssert = annotateLocation1 $ NAssert
|
|
||||||
<$> (reserved "assert" *> nixExprLoc)
|
|
||||||
<*> (semi *> nixExprLoc)
|
|
||||||
|
|
||||||
nixWith :: Parser NExprLoc
|
|
||||||
nixWith = annotateLocation1 $ NWith
|
|
||||||
<$> (reserved "with" *> nixExprLoc)
|
|
||||||
<*> (semi *> nixExprLoc)
|
|
||||||
|
|
||||||
nixLambda :: Parser NExprLoc
|
|
||||||
nixLambda = (nAbs <$> annotateLocation (try argExpr <?> "lambda arguments") <*> nixExprLoc) <?> "lambda"
|
|
||||||
|
|
||||||
nixStringExpr :: Parser NExprLoc
|
|
||||||
nixStringExpr = nStr <$> annotateLocation nixString
|
|
||||||
|
|
||||||
uriAfterColonC :: Parser Char
|
|
||||||
uriAfterColonC = alphaNum <|> oneOf "%/?:@&=+$,-_.!~*'"
|
|
||||||
|
|
||||||
nixUri :: Parser NExprLoc
|
|
||||||
nixUri = annotateLocation1 $ token $ fmap (mkUriF . pack) $ (++)
|
|
||||||
<$> try ((++) <$> (scheme <* char ':') <*> fmap (\x -> [':',x]) uriAfterColonC)
|
|
||||||
<*> many uriAfterColonC
|
|
||||||
where
|
|
||||||
scheme = (:) <$> letter <*> many (alphaNum <|> oneOf "+-.")
|
|
||||||
|
|
||||||
nixString :: Parser (NString NExprLoc)
|
|
||||||
nixString = doubleQuoted <|> indented <?> "string"
|
|
||||||
where
|
|
||||||
doubleQuoted :: Parser (NString NExprLoc)
|
|
||||||
doubleQuoted = DoubleQuoted . removePlainEmpty . mergePlain
|
|
||||||
<$> (doubleQ *> many (stringChar doubleQ (void $ char '\\') doubleEscape)
|
|
||||||
<* token doubleQ)
|
|
||||||
<?> "double quoted string"
|
|
||||||
|
|
||||||
doubleQ = void $ char '"'
|
|
||||||
doubleEscape = Plain . singleton <$> (char '\\' *> escapeCode)
|
|
||||||
|
|
||||||
indented :: Parser (NString NExprLoc)
|
|
||||||
indented = stripIndent
|
|
||||||
<$> (indentedQ *> many (stringChar indentedQ indentedQ indentedEscape)
|
|
||||||
<* token indentedQ)
|
|
||||||
<?> "indented string"
|
|
||||||
|
|
||||||
indentedQ = void $ try (string "''") <?> "\"''\""
|
|
||||||
indentedEscape = fmap Plain
|
|
||||||
$ try (indentedQ *> char '\\') *> fmap singleton escapeCode
|
|
||||||
<|> try (indentedQ *> ("''" <$ char '\'' <|> "$" <$ char '$'))
|
|
||||||
|
|
||||||
stringChar end escStart esc
|
|
||||||
= esc
|
|
||||||
<|> Antiquoted <$> (antiStart *> nixExprLoc <* char '}') -- don't skip trailing space
|
|
||||||
<|> Plain . singleton <$> char '$'
|
|
||||||
<|> Plain . pack <$> some plainChar
|
|
||||||
where plainChar = notFollowedBy (end <|> void (char '$') <|> escStart) *> anyChar
|
|
||||||
|
|
||||||
escapeCode = choice [ c <$ char e | (c,e) <- escapeCodes ] <|> anyChar
|
|
||||||
|
|
||||||
-- | Gets all of the arguments for a function.
|
|
||||||
argExpr :: Parser (Params NExprLoc)
|
|
||||||
argExpr = choice [atLeft, onlyname, atRight] <* symbolic ':' where
|
|
||||||
-- An argument not in curly braces. There's some potential ambiguity
|
|
||||||
-- in the case of, for example `x:y`. Is it a lambda function `x: y`, or
|
|
||||||
-- a URI `x:y`? Nix syntax says it's the latter. So we need to fail if
|
|
||||||
-- there's a valid URI parse here.
|
|
||||||
onlyname = choice [nixUri >> unexpected "valid uri",
|
|
||||||
Param <$> identifier]
|
|
||||||
|
|
||||||
-- Parameters named by an identifier on the left (`args @ {x, y}`)
|
|
||||||
atLeft = try $ do
|
|
||||||
name <- identifier <* symbolic '@'
|
|
||||||
(variadic, params) <- params
|
|
||||||
return $ ParamSet params variadic (Just name)
|
|
||||||
|
|
||||||
-- Parameters named by an identifier on the right, or none (`{x, y} @ args`)
|
|
||||||
atRight = do
|
|
||||||
(variadic, params) <- params
|
|
||||||
name <- optional $ symbolic '@' *> identifier
|
|
||||||
return $ ParamSet params variadic name
|
|
||||||
|
|
||||||
-- Return the parameters set.
|
|
||||||
params = do
|
|
||||||
(args, dotdots) <- braces getParams
|
|
||||||
return (dotdots, M.fromList args)
|
|
||||||
|
|
||||||
-- Collects the parameters within curly braces. Returns the parameters and
|
|
||||||
-- a boolean indicating if the parameters are variadic.
|
|
||||||
getParams :: Parser ([(Text, Maybe NExprLoc)], Bool)
|
|
||||||
getParams = go [] where
|
|
||||||
-- Attempt to parse `...`. If this succeeds, stop and return True.
|
|
||||||
-- Otherwise, attempt to parse an argument, optionally with a
|
|
||||||
-- default. If this fails, then return what has been accumulated
|
|
||||||
-- so far.
|
|
||||||
go acc = (token (string "...") >> return (acc, True)) <|> getMore acc
|
|
||||||
getMore acc =
|
|
||||||
-- Could be nothing, in which just return what we have so far.
|
|
||||||
option (acc, False) $ do
|
|
||||||
-- Get an argument name and an optional default.
|
|
||||||
pair <- liftA2 (,) identifier (optional $ symbolic '?' *> nixExprLoc)
|
|
||||||
-- Either return this, or attempt to get a comma and restart.
|
|
||||||
option (acc ++ [pair], False) $ symbolic ',' >> go (acc ++ [pair])
|
|
||||||
|
|
||||||
nixBinders :: Parser [Binding NExprLoc]
|
|
||||||
nixBinders = (inherit <|> namedVar) `endBy` symbolic ';' where
|
|
||||||
inherit = Inherit <$> (reserved "inherit" *> optional scope)
|
|
||||||
<*> many keyName
|
|
||||||
<?> "inherited binding"
|
|
||||||
namedVar = NamedVar <$> (annotated <$> nixSelector)
|
|
||||||
<*> (symbolic '=' *> nixExprLoc)
|
|
||||||
<?> "variable binding"
|
|
||||||
scope = parens nixExprLoc <?> "inherit scope"
|
|
||||||
|
|
||||||
keyName :: Parser (NKeyName NExprLoc)
|
|
||||||
keyName = dynamicKey <|> staticKey where
|
|
||||||
staticKey = do
|
|
||||||
beg <- position
|
|
||||||
StaticKey <$> identifier <*> pure (Just beg)
|
|
||||||
dynamicKey = DynamicKey <$> nixAntiquoted nixString
|
|
||||||
|
|
||||||
nixSet :: Parser NExprLoc
|
|
||||||
nixSet = annotateLocation1 $ (isRec <*> braces nixBinders) <?> "set" where
|
|
||||||
isRec = (try (reserved "rec" $> NRecSet) <?> "recursive set")
|
|
||||||
<|> pure NSet
|
|
||||||
|
|
||||||
parseNixFile :: MonadIO m => FilePath -> m (Result NExpr)
|
|
||||||
parseNixFile = parseFromFileEx $ nixExpr <* eof
|
|
||||||
|
|
||||||
parseNixFileLoc :: MonadIO m => FilePath -> m (Result NExprLoc)
|
|
||||||
parseNixFileLoc = parseFromFileEx $ nixExprLoc <* eof
|
|
||||||
|
|
||||||
parseNixString :: String -> Result NExpr
|
|
||||||
parseNixString = parseFromString $ nixExpr <* eof
|
|
||||||
|
|
||||||
parseNixStringLoc :: String -> Result NExprLoc
|
|
||||||
parseNixStringLoc = parseFromString $ nixExprLoc <* eof
|
|
||||||
|
|
||||||
parseNixText :: Text -> Result NExpr
|
|
||||||
parseNixText = parseNixString . unpack
|
|
||||||
|
|
||||||
parseNixTextLoc :: Text -> Result NExprLoc
|
|
||||||
parseNixTextLoc = parseNixStringLoc . unpack
|
|
|
@ -1,173 +0,0 @@
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
|
|
||||||
module Nix.Parser.Library
|
|
||||||
( module Nix.Parser.Library
|
|
||||||
, module X
|
|
||||||
, Trifecta.Delta(..)
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Applicative
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Data.Functor
|
|
||||||
import qualified Data.HashSet as HashSet
|
|
||||||
import Data.List (nub)
|
|
||||||
import Data.Text
|
|
||||||
import Text.Parser.Char as X hiding (text)
|
|
||||||
import Text.Parser.Combinators as X
|
|
||||||
import Text.Parser.Expression as X
|
|
||||||
import Text.Parser.LookAhead as X
|
|
||||||
import Text.Parser.Token as X
|
|
||||||
import Text.Parser.Token.Highlight
|
|
||||||
import Text.Parser.Token.Style
|
|
||||||
import Text.PrettyPrint.ANSI.Leijen as X (Doc, text)
|
|
||||||
#if USE_PARSEC
|
|
||||||
import qualified Text.Parsec as Parsec
|
|
||||||
import qualified Text.Parsec.Text as Parsec
|
|
||||||
import qualified Data.Text.IO as T
|
|
||||||
#else
|
|
||||||
import qualified Text.Trifecta as Trifecta
|
|
||||||
import qualified Text.Trifecta.Delta as Trifecta
|
|
||||||
|
|
||||||
import Text.Trifecta as X (Result(..))
|
|
||||||
#endif
|
|
||||||
|
|
||||||
newtype NixParser p a = NixParser { runNixParser :: p a }
|
|
||||||
deriving (Functor, Applicative, Alternative, Monad, MonadPlus, Parsing, CharParsing, LookAheadParsing, Trifecta.DeltaParsing)
|
|
||||||
|
|
||||||
instance TokenParsing p => TokenParsing (NixParser p) where
|
|
||||||
someSpace = NixParser $ buildSomeSpaceParser' someSpace commentStyle
|
|
||||||
nesting = NixParser . nesting . runNixParser
|
|
||||||
highlight h = NixParser . highlight h . runNixParser
|
|
||||||
semi = token $ char ';' <?> ";"
|
|
||||||
token p = p <* whiteSpace
|
|
||||||
|
|
||||||
buildSomeSpaceParser' :: forall m. CharParsing m => m () -> CommentStyle -> m ()
|
|
||||||
buildSomeSpaceParser' simpleSpace
|
|
||||||
(CommentStyle startStyle endStyle lineStyle nestingStyle)
|
|
||||||
| noLine && noMulti = skipSome (simpleSpace <?> "")
|
|
||||||
| noLine = skipSome (simpleSpace <|> multiLineComment <?> "")
|
|
||||||
| noMulti = skipSome (simpleSpace <|> oneLineComment <?> "")
|
|
||||||
| otherwise =
|
|
||||||
skipSome (simpleSpace <|> oneLineComment <|> multiLineComment <?> "")
|
|
||||||
where
|
|
||||||
noLine = Prelude.null lineStyle
|
|
||||||
noMulti = Prelude.null startStyle
|
|
||||||
|
|
||||||
oneLineComment, multiLineComment, inComment, inCommentMulti :: m ()
|
|
||||||
oneLineComment = try (string lineStyle) *> skipMany (satisfy (\x -> x `notElem` ['\r', '\n']))
|
|
||||||
multiLineComment = try (string startStyle) *> inComment
|
|
||||||
inComment = if nestingStyle then inCommentMulti else inCommentSingle
|
|
||||||
inCommentMulti
|
|
||||||
= () <$ try (string endStyle)
|
|
||||||
<|> multiLineComment *> inCommentMulti
|
|
||||||
<|> skipSome (noneOf startEnd) *> inCommentMulti
|
|
||||||
<|> oneOf startEnd *> inCommentMulti
|
|
||||||
<?> "end of comment"
|
|
||||||
|
|
||||||
startEnd = nub (endStyle ++ startStyle)
|
|
||||||
|
|
||||||
inCommentSingle :: m ()
|
|
||||||
inCommentSingle
|
|
||||||
= () <$ try (string endStyle)
|
|
||||||
<|> skipSome (noneOf startEnd) *> inCommentSingle
|
|
||||||
<|> oneOf startEnd *> inCommentSingle
|
|
||||||
<?> "end of comment"
|
|
||||||
|
|
||||||
commentStyle :: CommentStyle
|
|
||||||
commentStyle = CommentStyle
|
|
||||||
{ _commentStart = "/*"
|
|
||||||
, _commentEnd = "*/"
|
|
||||||
, _commentLine = "#"
|
|
||||||
, _commentNesting = False
|
|
||||||
}
|
|
||||||
|
|
||||||
identStyle :: CharParsing m => IdentifierStyle m
|
|
||||||
identStyle = IdentifierStyle
|
|
||||||
{ _styleName = "identifier"
|
|
||||||
, _styleStart = identStart
|
|
||||||
, _styleLetter = identLetter
|
|
||||||
, _styleReserved = reservedNames
|
|
||||||
, _styleHighlight = Identifier
|
|
||||||
, _styleReservedHighlight = ReservedIdentifier
|
|
||||||
}
|
|
||||||
|
|
||||||
identifier :: (TokenParsing m, Monad m) => m Text
|
|
||||||
identifier = ident identStyle <?> "identifier"
|
|
||||||
|
|
||||||
reserved :: (TokenParsing m, Monad m) => String -> m ()
|
|
||||||
reserved = reserve identStyle
|
|
||||||
|
|
||||||
reservedOp :: TokenParsing m => String -> m ()
|
|
||||||
reservedOp o = token $ try $ void $
|
|
||||||
highlight ReservedOperator (string o)
|
|
||||||
<* (notFollowedBy opLetter <?> "end of " ++ o)
|
|
||||||
|
|
||||||
opStart :: CharParsing m => m Char
|
|
||||||
opStart = oneOf ".+-*/=<>&|!?"
|
|
||||||
|
|
||||||
opLetter :: CharParsing m => m Char
|
|
||||||
opLetter = oneOf ">+/&|="
|
|
||||||
|
|
||||||
identStart :: CharParsing m => m Char
|
|
||||||
identStart = letter <|> char '_'
|
|
||||||
|
|
||||||
identLetter :: CharParsing m => m Char
|
|
||||||
identLetter = alphaNum <|> oneOf "_'-"
|
|
||||||
|
|
||||||
reservedNames :: HashSet.HashSet String
|
|
||||||
reservedNames = HashSet.fromList
|
|
||||||
[ "let", "in"
|
|
||||||
, "if", "then", "else"
|
|
||||||
, "assert"
|
|
||||||
, "with"
|
|
||||||
, "rec"
|
|
||||||
, "inherit"
|
|
||||||
, "true"
|
|
||||||
, "false"
|
|
||||||
]
|
|
||||||
|
|
||||||
stopWords :: (TokenParsing m, Monad m) => m ()
|
|
||||||
stopWords = () <$
|
|
||||||
(whiteSpace *> (reserved "in" <|> reserved "then" <|> reserved "else"))
|
|
||||||
|
|
||||||
someTill :: Alternative f => f a -> f end -> f [a]
|
|
||||||
someTill p end = go
|
|
||||||
where
|
|
||||||
go = (:) <$> p <*> scan
|
|
||||||
scan = (end $> []) <|> go
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
parseFromFileEx :: MonadIO m => Parser a -> FilePath -> m (Result a)
|
|
||||||
parseFromString :: Parser a -> String -> Result a
|
|
||||||
position :: Parser Trifecta.Delta
|
|
||||||
|
|
||||||
#if USE_PARSEC
|
|
||||||
data Result a = Success a
|
|
||||||
| Failure Doc
|
|
||||||
deriving Show
|
|
||||||
|
|
||||||
type Parser = NixParser Parsec.Parser
|
|
||||||
|
|
||||||
parseFromFileEx p path =
|
|
||||||
(either (Failure . text . show) Success . Parsec.parse (runNixParser p) path)
|
|
||||||
`liftM` liftIO (T.readFile path)
|
|
||||||
|
|
||||||
parseFromString p = either (Failure . text . show) Success . Parsec.parse (runNixParser p) "<string>" . pack
|
|
||||||
|
|
||||||
position = error "position not implemented for Parsec parser"
|
|
||||||
|
|
||||||
#else
|
|
||||||
|
|
||||||
type Parser = NixParser Trifecta.Parser
|
|
||||||
|
|
||||||
parseFromFileEx p = Trifecta.parseFromFileEx (runNixParser p)
|
|
||||||
|
|
||||||
parseFromString p = Trifecta.parseString (runNixParser p) (Trifecta.Directed "<string>" 0 0 0 0)
|
|
||||||
|
|
||||||
position = Trifecta.position
|
|
||||||
|
|
||||||
#endif
|
|
|
@ -1,82 +0,0 @@
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
|
|
||||||
module Nix.Parser.Operators where
|
|
||||||
|
|
||||||
import Data.Data (Data(..))
|
|
||||||
import Data.Foldable (concat)
|
|
||||||
import qualified Data.Map as Map
|
|
||||||
import Data.Maybe (catMaybes)
|
|
||||||
import Data.Typeable (Typeable)
|
|
||||||
import GHC.Generics
|
|
||||||
import Nix.Expr
|
|
||||||
|
|
||||||
data NSpecialOp = NHasAttrOp | NSelectOp | NAppOp
|
|
||||||
deriving (Eq, Ord, Generic, Typeable, Data, Show)
|
|
||||||
|
|
||||||
data NAssoc = NAssocNone | NAssocLeft | NAssocRight
|
|
||||||
deriving (Eq, Ord, Generic, Typeable, Data, Show)
|
|
||||||
|
|
||||||
data NOperatorDef
|
|
||||||
= NUnaryDef String NUnaryOp
|
|
||||||
| NBinaryDef NAssoc [(String, NBinaryOp)]
|
|
||||||
deriving (Eq, Ord, Generic, Typeable, Data, Show)
|
|
||||||
|
|
||||||
nixOperators :: [Either NSpecialOp NOperatorDef]
|
|
||||||
nixOperators =
|
|
||||||
[ Left NSelectOp
|
|
||||||
, Left NAppOp
|
|
||||||
, Right $ NUnaryDef "-" NNeg
|
|
||||||
, Left NHasAttrOp
|
|
||||||
] ++ map Right
|
|
||||||
[ NBinaryDef NAssocRight [("++", NConcat)]
|
|
||||||
, NBinaryDef NAssocLeft [("*", NMult), ("/", NDiv)]
|
|
||||||
, NBinaryDef NAssocLeft [("+", NPlus), ("-", NMinus)]
|
|
||||||
, NUnaryDef "!" NNot
|
|
||||||
, NBinaryDef NAssocRight [("//", NUpdate)]
|
|
||||||
, NBinaryDef NAssocLeft [("<", NLt), (">", NGt), ("<=", NLte), (">=", NGte)]
|
|
||||||
, NBinaryDef NAssocNone [("==", NEq), ("!=", NNEq)]
|
|
||||||
, NBinaryDef NAssocLeft [("&&", NAnd)]
|
|
||||||
, NBinaryDef NAssocLeft [("||", NOr)]
|
|
||||||
, NBinaryDef NAssocNone [("->", NImpl)]
|
|
||||||
]
|
|
||||||
|
|
||||||
data OperatorInfo = OperatorInfo
|
|
||||||
{ precedence :: Int
|
|
||||||
, associativity :: NAssoc
|
|
||||||
, operatorName :: String
|
|
||||||
} deriving (Eq, Ord, Generic, Typeable, Data, Show)
|
|
||||||
|
|
||||||
getUnaryOperator :: NUnaryOp -> OperatorInfo
|
|
||||||
getUnaryOperator = (m Map.!) where
|
|
||||||
m = Map.fromList . concat . zipWith buildEntry [1..] . reverse $
|
|
||||||
nixOperators
|
|
||||||
buildEntry i = \case
|
|
||||||
Right (NUnaryDef name op) -> [(op, OperatorInfo i NAssocNone name)]
|
|
||||||
_ -> []
|
|
||||||
|
|
||||||
getBinaryOperator :: NBinaryOp -> OperatorInfo
|
|
||||||
getBinaryOperator = (m Map.!) where
|
|
||||||
m = Map.fromList . concat . zipWith buildEntry [1..] . reverse $
|
|
||||||
nixOperators
|
|
||||||
buildEntry i = \case
|
|
||||||
Right (NBinaryDef assoc ops) ->
|
|
||||||
[(op, OperatorInfo i assoc name) | (name,op) <- ops]
|
|
||||||
_ -> []
|
|
||||||
|
|
||||||
getSpecialOperatorPrec :: NSpecialOp -> Int
|
|
||||||
getSpecialOperatorPrec = (m Map.!) where
|
|
||||||
m = Map.fromList . catMaybes . zipWith buildEntry [1..] . reverse $
|
|
||||||
nixOperators
|
|
||||||
buildEntry _ (Right _) = Nothing
|
|
||||||
buildEntry i (Left op) = Just (op, i)
|
|
||||||
|
|
||||||
selectOp :: OperatorInfo
|
|
||||||
selectOp = OperatorInfo (getSpecialOperatorPrec NSelectOp) NAssocLeft "."
|
|
||||||
|
|
||||||
hasAttrOp :: OperatorInfo
|
|
||||||
hasAttrOp = OperatorInfo (getSpecialOperatorPrec NHasAttrOp) NAssocLeft "?"
|
|
||||||
|
|
||||||
appOp :: OperatorInfo
|
|
||||||
appOp = OperatorInfo (getSpecialOperatorPrec NAppOp) NAssocLeft " "
|
|
225
Nix/Pretty.hs
225
Nix/Pretty.hs
|
@ -1,225 +0,0 @@
|
||||||
{-# LANGUAGE RankNTypes #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
|
||||||
|
|
||||||
module Nix.Pretty where
|
|
||||||
|
|
||||||
import Data.Fix
|
|
||||||
import Data.HashMap.Lazy (toList)
|
|
||||||
import qualified Data.HashMap.Lazy as M
|
|
||||||
import qualified Data.HashMap.Strict.InsOrd as OM
|
|
||||||
import qualified Data.HashSet as HashSet
|
|
||||||
import Data.List (isPrefixOf, sort)
|
|
||||||
import Data.Maybe (isJust)
|
|
||||||
import Data.Text (pack, unpack, replace, strip)
|
|
||||||
import qualified Data.Text as Text
|
|
||||||
import Nix.Atoms
|
|
||||||
import Nix.Expr
|
|
||||||
import Nix.Value
|
|
||||||
import Nix.Parser.Library (reservedNames)
|
|
||||||
import Nix.Parser.Operators
|
|
||||||
import Nix.StringOperations
|
|
||||||
import Nix.Thunk
|
|
||||||
import Prelude hiding ((<$>))
|
|
||||||
import Text.PrettyPrint.ANSI.Leijen
|
|
||||||
|
|
||||||
-- | This type represents a pretty printed nix expression
|
|
||||||
-- together with some information about the expression.
|
|
||||||
data NixDoc = NixDoc
|
|
||||||
{ -- | The rendered expression, without any parentheses.
|
|
||||||
withoutParens :: Doc
|
|
||||||
|
|
||||||
-- | The root operator is the operator at the root of
|
|
||||||
-- the expression tree. For example, in '(a * b) + c', '+' would be the root
|
|
||||||
-- operator. It is needed to determine if we need to wrap the expression in
|
|
||||||
-- parentheses.
|
|
||||||
, rootOp :: OperatorInfo
|
|
||||||
}
|
|
||||||
|
|
||||||
-- | A simple expression is never wrapped in parentheses. The expression
|
|
||||||
-- behaves as if its root operator had a precedence higher than all
|
|
||||||
-- other operators (including function application).
|
|
||||||
simpleExpr :: Doc -> NixDoc
|
|
||||||
simpleExpr = flip NixDoc $ OperatorInfo maxBound NAssocNone "simple expr"
|
|
||||||
|
|
||||||
-- | An expression that behaves as if its root operator
|
|
||||||
-- had a precedence lower than all other operators.
|
|
||||||
-- That ensures that the expression is wrapped in parantheses in
|
|
||||||
-- almost always, but it's still rendered without parentheses
|
|
||||||
-- in cases where parentheses are never required (such as in the LHS
|
|
||||||
-- of a binding).
|
|
||||||
leastPrecedence :: Doc -> NixDoc
|
|
||||||
leastPrecedence = flip NixDoc $ OperatorInfo minBound NAssocNone "least precedence"
|
|
||||||
|
|
||||||
appOpNonAssoc :: OperatorInfo
|
|
||||||
appOpNonAssoc = appOp { associativity = NAssocNone }
|
|
||||||
|
|
||||||
wrapParens :: OperatorInfo -> NixDoc -> Doc
|
|
||||||
wrapParens op sub
|
|
||||||
| precedence (rootOp sub) > precedence op = withoutParens sub
|
|
||||||
| precedence (rootOp sub) == precedence op
|
|
||||||
&& associativity (rootOp sub) == associativity op
|
|
||||||
&& associativity op /= NAssocNone = withoutParens sub
|
|
||||||
| otherwise = parens $ withoutParens sub
|
|
||||||
|
|
||||||
prettyString :: NString NixDoc -> Doc
|
|
||||||
prettyString (DoubleQuoted parts) = dquotes . hcat . map prettyPart $ parts
|
|
||||||
where prettyPart (Plain t) = text . concatMap escape . unpack $ t
|
|
||||||
prettyPart (Antiquoted r) = text "$" <> braces (withoutParens r)
|
|
||||||
escape '"' = "\\\""
|
|
||||||
escape x = maybe [x] (('\\':) . (:[])) $ toEscapeCode x
|
|
||||||
prettyString (Indented parts)
|
|
||||||
= group $ nest 2 (squote <> squote <$$> content) <$$> squote <> squote
|
|
||||||
where
|
|
||||||
content = vsep . map prettyLine . stripLastIfEmpty . splitLines $ parts
|
|
||||||
stripLastIfEmpty = reverse . f . reverse where
|
|
||||||
f ([Plain t] : xs) | Text.null (strip t) = xs
|
|
||||||
f xs = xs
|
|
||||||
prettyLine = hcat . map prettyPart
|
|
||||||
prettyPart (Plain t) = text . unpack . replace "${" "''${" . replace "''" "'''" $ t
|
|
||||||
prettyPart (Antiquoted r) = text "$" <> braces (withoutParens r)
|
|
||||||
|
|
||||||
prettyParams :: Params NixDoc -> Doc
|
|
||||||
prettyParams (Param n) = text $ unpack n
|
|
||||||
prettyParams (ParamSet s v mname) = prettyParamSet s v <> case mname of
|
|
||||||
Nothing -> empty
|
|
||||||
Just name -> text "@" <> text (unpack name)
|
|
||||||
|
|
||||||
prettyParamSet :: ParamSet NixDoc -> Bool -> Doc
|
|
||||||
prettyParamSet args var =
|
|
||||||
encloseSep (lbrace <> space) (align rbrace) sep prettyArgs
|
|
||||||
where
|
|
||||||
prettySetArg (n, maybeDef) = case maybeDef of
|
|
||||||
Nothing -> text (unpack n)
|
|
||||||
Just v -> text (unpack n) <+> text "?" <+> withoutParens v
|
|
||||||
prettyArgs
|
|
||||||
| var = map prettySetArg (OM.toList args)
|
|
||||||
| otherwise = map prettySetArg (OM.toList args) ++ [text "..."]
|
|
||||||
sep = align (comma <> space)
|
|
||||||
|
|
||||||
prettyBind :: Binding NixDoc -> Doc
|
|
||||||
prettyBind (NamedVar n v) =
|
|
||||||
prettySelector n <+> equals <+> withoutParens v <> semi
|
|
||||||
prettyBind (Inherit s ns)
|
|
||||||
= text "inherit" <+> scope <> align (fillSep (map prettyKeyName ns)) <> semi
|
|
||||||
where scope = maybe empty ((<> space) . parens . withoutParens) s
|
|
||||||
|
|
||||||
prettyKeyName :: NKeyName NixDoc -> Doc
|
|
||||||
prettyKeyName (StaticKey "" _) = dquotes $ text ""
|
|
||||||
prettyKeyName (StaticKey key _)
|
|
||||||
| HashSet.member (unpack key) reservedNames = dquotes $ text $ unpack key
|
|
||||||
prettyKeyName (StaticKey key _) = text . unpack $ key
|
|
||||||
prettyKeyName (DynamicKey key) = runAntiquoted prettyString withoutParens key
|
|
||||||
|
|
||||||
prettySelector :: NAttrPath NixDoc -> Doc
|
|
||||||
prettySelector = hcat . punctuate dot . map prettyKeyName
|
|
||||||
|
|
||||||
prettyAtom :: NAtom -> NixDoc
|
|
||||||
prettyAtom atom = simpleExpr $ text $ unpack $ atomText atom
|
|
||||||
|
|
||||||
prettyNix :: NExpr -> Doc
|
|
||||||
prettyNix = withoutParens . cata phi where
|
|
||||||
phi :: NExprF NixDoc -> NixDoc
|
|
||||||
phi (NConstant atom) = prettyAtom atom
|
|
||||||
phi (NStr str) = simpleExpr $ prettyString str
|
|
||||||
phi (NList []) = simpleExpr $ lbracket <> rbracket
|
|
||||||
phi (NList xs) = simpleExpr $ group $
|
|
||||||
nest 2 (vsep $ lbracket : map (wrapParens appOpNonAssoc) xs) <$> rbracket
|
|
||||||
phi (NSet []) = simpleExpr $ lbrace <> rbrace
|
|
||||||
phi (NSet xs) = simpleExpr $ group $
|
|
||||||
nest 2 (vsep $ lbrace : map prettyBind xs) <$> rbrace
|
|
||||||
phi (NRecSet []) = simpleExpr $ recPrefix <> lbrace <> rbrace
|
|
||||||
phi (NRecSet xs) = simpleExpr $ group $
|
|
||||||
nest 2 (vsep $ recPrefix <> lbrace : map prettyBind xs) <$> rbrace
|
|
||||||
phi (NAbs args body) = leastPrecedence $
|
|
||||||
(prettyParams args <> colon) </> indent 2 (withoutParens body)
|
|
||||||
phi (NBinary op r1 r2) = flip NixDoc opInfo $ hsep
|
|
||||||
[ wrapParens (f NAssocLeft) r1
|
|
||||||
, text $ operatorName opInfo
|
|
||||||
, wrapParens (f NAssocRight) r2
|
|
||||||
]
|
|
||||||
where
|
|
||||||
opInfo = getBinaryOperator op
|
|
||||||
f x
|
|
||||||
| associativity opInfo /= x = opInfo { associativity = NAssocNone }
|
|
||||||
| otherwise = opInfo
|
|
||||||
phi (NUnary op r1) =
|
|
||||||
NixDoc (text (operatorName opInfo) <> wrapParens opInfo r1) opInfo
|
|
||||||
where opInfo = getUnaryOperator op
|
|
||||||
phi (NSelect r [] _) = r
|
|
||||||
phi (NSelect r attr o) = (if isJust o then leastPrecedence else flip NixDoc selectOp) $
|
|
||||||
wrapParens selectOp r <> dot <> prettySelector attr <> ordoc
|
|
||||||
where ordoc = maybe empty (((space <> text "or") <+>) . withoutParens) o
|
|
||||||
phi (NHasAttr r attr)
|
|
||||||
= NixDoc (wrapParens hasAttrOp r <+> text "?" <+> prettySelector attr) hasAttrOp
|
|
||||||
phi (NApp fun arg)
|
|
||||||
= NixDoc (wrapParens appOp fun <+> wrapParens appOpNonAssoc arg) appOp
|
|
||||||
phi (NEnvPath p) = simpleExpr $ text ("<" ++ p ++ ">")
|
|
||||||
phi (NLiteralPath p) = simpleExpr $ text $ case p of
|
|
||||||
"./" -> "./."
|
|
||||||
"../" -> "../."
|
|
||||||
".." -> "../."
|
|
||||||
txt | "/" `isPrefixOf` txt -> txt
|
|
||||||
| "./" `isPrefixOf` txt -> txt
|
|
||||||
| "../" `isPrefixOf` txt -> txt
|
|
||||||
| otherwise -> "./" ++ txt
|
|
||||||
phi (NSym name) = simpleExpr $ text (unpack name)
|
|
||||||
phi (NLet binds body) = leastPrecedence $ group $ text "let" <$> indent 2 (
|
|
||||||
vsep (map prettyBind binds)) <$> text "in" <+> withoutParens body
|
|
||||||
phi (NIf cond trueBody falseBody) = leastPrecedence $
|
|
||||||
group $ nest 2 $ (text "if" <+> withoutParens cond) <$>
|
|
||||||
( align (text "then" <+> withoutParens trueBody)
|
|
||||||
<$> align (text "else" <+> withoutParens falseBody)
|
|
||||||
)
|
|
||||||
phi (NWith scope body) = leastPrecedence $
|
|
||||||
text "with" <+> withoutParens scope <> semi <$> align (withoutParens body)
|
|
||||||
phi (NAssert cond body) = leastPrecedence $
|
|
||||||
text "assert" <+> withoutParens cond <> semi <$> align (withoutParens body)
|
|
||||||
|
|
||||||
recPrefix = text "rec" <> space
|
|
||||||
|
|
||||||
prettyNixValue :: Functor m => NValueNF m -> Doc
|
|
||||||
prettyNixValue = prettyNix . valueToExpr
|
|
||||||
where valueToExpr :: Functor m => NValueNF m -> NExpr
|
|
||||||
valueToExpr = hmap go
|
|
||||||
-- hmap does the recursive conversion from NValue to NExpr.
|
|
||||||
-- fun fact: it is not defined in data-fixed, but I was certain it
|
|
||||||
-- should exists so I found it in unification-fd by hoogling its type
|
|
||||||
hmap :: (Functor f, Functor g) => (forall a. f a -> g a)
|
|
||||||
-> Fix f -> Fix g
|
|
||||||
hmap eps = ana (eps . unFix)
|
|
||||||
go (NVConstant a) = NConstant a
|
|
||||||
go (NVStr t _) = NStr (DoubleQuoted [Plain t])
|
|
||||||
go (NVList l) = NList l
|
|
||||||
go (NVSet s p) = NSet [ NamedVar [StaticKey k (M.lookup k p)] v
|
|
||||||
| (k, v) <- toList s ]
|
|
||||||
go (NVClosure s p _) =
|
|
||||||
NSym . pack $ "<closure in " ++ show s
|
|
||||||
++ " with " ++ show (() <$ p) ++ ">"
|
|
||||||
go (NVLiteralPath fp) = NLiteralPath fp
|
|
||||||
go (NVEnvPath p) = NEnvPath p
|
|
||||||
go (NVBuiltin name _) = NSym $ Text.pack $ "builtins." ++ name
|
|
||||||
|
|
||||||
printNix :: Functor m => NValueNF m -> String
|
|
||||||
printNix = cata phi
|
|
||||||
where phi :: NValueF m String -> String
|
|
||||||
phi (NVConstant a) = unpack $ atomText a
|
|
||||||
phi (NVStr t _) = show t
|
|
||||||
phi (NVList l) = "[ " ++ unwords l ++ " ]"
|
|
||||||
phi (NVSet s _) =
|
|
||||||
"{ " ++ concat [ unpack k ++ " = " ++ v ++ "; "
|
|
||||||
| (k, v) <- sort $ toList s ] ++ "}"
|
|
||||||
phi NVClosure {} = "<<lambda>>"
|
|
||||||
phi (NVLiteralPath fp) = fp
|
|
||||||
phi (NVEnvPath p) = p
|
|
||||||
phi (NVBuiltin name _) = "<<builtin " ++ name ++ ">>"
|
|
||||||
|
|
||||||
removeEffects :: Functor m => NValue m -> NValueNF m
|
|
||||||
removeEffects = Fix . fmap dethunk
|
|
||||||
where
|
|
||||||
dethunk (NThunk (Value v)) = removeEffects v
|
|
||||||
dethunk (NThunk _) = Fix $ NVStr "<thunk>" mempty
|
|
||||||
|
|
||||||
showValue :: Functor m => NValue m -> String
|
|
||||||
showValue = show . prettyNixValue . removeEffects
|
|
83
Nix/Scope.hs
83
Nix/Scope.hs
|
@ -1,83 +0,0 @@
|
||||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
|
||||||
{-# LANGUAGE ConstraintKinds #-}
|
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
|
||||||
{-# LANGUAGE DeriveFoldable #-}
|
|
||||||
{-# LANGUAGE DeriveTraversable #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
|
|
||||||
module Nix.Scope where
|
|
||||||
|
|
||||||
import Control.Applicative
|
|
||||||
import Control.Monad.Reader
|
|
||||||
import Data.HashMap.Lazy (HashMap)
|
|
||||||
import qualified Data.HashMap.Lazy as M
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Nix.Utils
|
|
||||||
|
|
||||||
data Scope m a
|
|
||||||
= Scope (HashMap Text a)
|
|
||||||
| WeakScope (m (HashMap Text a))
|
|
||||||
-- ^ Weak scopes (used by 'with') are delayed until first needed.
|
|
||||||
deriving (Functor, Foldable, Traversable)
|
|
||||||
|
|
||||||
instance Show (Scope m a) where
|
|
||||||
show (Scope m) = show (M.keys m)
|
|
||||||
show (WeakScope _) = "<weak scope>"
|
|
||||||
|
|
||||||
newScope :: HashMap Text a -> Scope m a
|
|
||||||
newScope = Scope
|
|
||||||
|
|
||||||
newWeakScope :: m (HashMap Text a) -> Scope m a
|
|
||||||
newWeakScope = WeakScope
|
|
||||||
|
|
||||||
isWeakScope :: Scope m a -> Bool
|
|
||||||
isWeakScope (WeakScope _) = True
|
|
||||||
isWeakScope _ = False
|
|
||||||
|
|
||||||
scopeLookup :: Monad m => Text -> [Scope m v] -> m (Maybe v)
|
|
||||||
scopeLookup key = paraM go Nothing
|
|
||||||
where
|
|
||||||
go (Scope m) _ rest = return $ M.lookup key m <|> rest
|
|
||||||
go (WeakScope m) ms rest = do
|
|
||||||
-- If the symbol lookup is in a weak scope, first see if there are any
|
|
||||||
-- matching symbols from the *non-weak* scopes after this one. If so,
|
|
||||||
-- prefer that, otherwise perform the lookup here. This way, if there
|
|
||||||
-- are several weaks scopes in a row, followed by non-weak scopes,
|
|
||||||
-- we'll first prefer the symbol from the non-weak scopes, and then
|
|
||||||
-- prefer it from the first weak scope that matched.
|
|
||||||
mres <- scopeLookup key (filter (not . isWeakScope) ms)
|
|
||||||
case mres of
|
|
||||||
Nothing -> m >>= \m' ->
|
|
||||||
return $ M.lookup key m' <|> rest
|
|
||||||
_ -> return mres
|
|
||||||
|
|
||||||
type Scopes m v = [Scope m v]
|
|
||||||
|
|
||||||
type Scoped e v m = (MonadReader e m, Has e (Scopes m v))
|
|
||||||
|
|
||||||
emptyScopes :: Scopes m v
|
|
||||||
emptyScopes = []
|
|
||||||
|
|
||||||
currentScopes :: Scoped e v m => m (Scopes m v)
|
|
||||||
currentScopes = asks (view hasLens)
|
|
||||||
|
|
||||||
clearScopes :: forall v m e r. Scoped e v m => m r -> m r
|
|
||||||
clearScopes = local (set hasLens ([] :: [Scope m v]))
|
|
||||||
|
|
||||||
pushScope :: forall v m e r. Scoped e v m => HashMap Text v -> m r -> m r
|
|
||||||
pushScope s = local (over hasLens (Scope @m s :))
|
|
||||||
|
|
||||||
pushWeakScope :: forall v m e r. Scoped e v m
|
|
||||||
=> m (HashMap Text v) -> m r -> m r
|
|
||||||
pushWeakScope s = local (over hasLens (WeakScope s :))
|
|
||||||
|
|
||||||
pushScopes :: Scoped e v m => Scopes m v -> m r -> m r
|
|
||||||
pushScopes s = local (over hasLens (s ++))
|
|
||||||
|
|
||||||
lookupVar :: forall e v m. (Scoped e v m, Monad m) => Text -> m (Maybe v)
|
|
||||||
lookupVar k = join $ asks (scopeLookup @m k . view hasLens)
|
|
||||||
|
|
||||||
withScopes :: forall v m e a. Scoped e v m => Scopes m v -> m a -> m a
|
|
||||||
withScopes scope = clearScopes @v . pushScopes scope
|
|
59
Nix/Stack.hs
59
Nix/Stack.hs
|
@ -1,59 +0,0 @@
|
||||||
{-# LANGUAGE ConstraintKinds #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
|
|
||||||
module Nix.Stack where
|
|
||||||
|
|
||||||
import Control.Monad.Reader
|
|
||||||
import Data.ByteString (ByteString)
|
|
||||||
import Data.Fix
|
|
||||||
import Data.Functor.Compose
|
|
||||||
import qualified Data.Text as Text
|
|
||||||
import qualified Data.Text.Encoding as Text
|
|
||||||
import Nix.Expr.Types
|
|
||||||
import Nix.Expr.Types.Annotated
|
|
||||||
import Nix.Pretty
|
|
||||||
import Nix.Utils
|
|
||||||
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
|
|
||||||
import Text.Trifecta.Rendering
|
|
||||||
import Text.Trifecta.Result
|
|
||||||
|
|
||||||
type Frames = [Either String (NExprLocF ())]
|
|
||||||
|
|
||||||
type Framed e m = (MonadReader e m, Has e Frames)
|
|
||||||
|
|
||||||
withExprContext :: Framed e m => NExprLocF () -> m r -> m r
|
|
||||||
withExprContext expr = local (over hasLens (Right @String expr :))
|
|
||||||
|
|
||||||
withStringContext :: Framed e m => String -> m r -> m r
|
|
||||||
withStringContext str = local (over hasLens (Left @_ @(NExprLocF ()) str :))
|
|
||||||
|
|
||||||
class Monad m => MonadFile m where
|
|
||||||
readFile :: FilePath -> m ByteString
|
|
||||||
|
|
||||||
renderLocation :: MonadFile m => SrcSpan -> Doc -> m Doc
|
|
||||||
renderLocation (SrcSpan beg@(Directed "<string>" _ _ _ _) end) msg =
|
|
||||||
return $ explain (addSpan beg end emptyRendering)
|
|
||||||
(Err (Just msg) [] mempty [])
|
|
||||||
renderLocation (SrcSpan beg@(Directed path _ _ _ _) end) msg = do
|
|
||||||
contents <- Nix.Stack.readFile (Text.unpack (Text.decodeUtf8 path))
|
|
||||||
return $ explain (addSpan beg end (rendered beg contents))
|
|
||||||
(Err (Just msg) [] mempty [])
|
|
||||||
renderLocation (SrcSpan beg end) msg =
|
|
||||||
return $ explain (addSpan beg end emptyRendering)
|
|
||||||
(Err (Just msg) [] mempty [])
|
|
||||||
|
|
||||||
renderFrame :: MonadFile m => Either String (NExprLocF ()) -> m String
|
|
||||||
renderFrame (Left str) = return str
|
|
||||||
renderFrame (Right (Compose (Ann ann expr))) =
|
|
||||||
show <$> renderLocation ann
|
|
||||||
(prettyNix (Fix (const (Fix (NSym "<?>")) <$> expr)))
|
|
||||||
|
|
||||||
throwError :: (Framed e m, MonadFile m) => String -> m a
|
|
||||||
throwError str = do
|
|
||||||
context <- asks (reverse . view hasLens)
|
|
||||||
infos <- mapM renderFrame context
|
|
||||||
errorWithoutStackTrace $ unlines (infos ++ ["hnix: "++ str])
|
|
|
@ -1,27 +0,0 @@
|
||||||
{-# LANGUAGE ConstraintKinds #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
|
|
||||||
module Nix.Stack where
|
|
||||||
|
|
||||||
import Control.Monad.Reader
|
|
||||||
import Data.ByteString (ByteString)
|
|
||||||
import Nix.Expr.Types.Annotated
|
|
||||||
import Nix.Utils
|
|
||||||
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
|
|
||||||
|
|
||||||
type Frames = [Either String (NExprLocF ())]
|
|
||||||
|
|
||||||
type Framed e m = (MonadReader e m, Has e Frames)
|
|
||||||
|
|
||||||
withExprContext :: Framed e m => NExprLocF () -> m r -> m r
|
|
||||||
|
|
||||||
withStringContext :: Framed e m => String -> m r -> m r
|
|
||||||
|
|
||||||
class Monad m => MonadFile m where
|
|
||||||
readFile :: FilePath -> m ByteString
|
|
||||||
|
|
||||||
renderLocation :: MonadFile m => SrcSpan -> Doc -> m Doc
|
|
||||||
|
|
||||||
renderFrame :: MonadFile m => Either String (NExprLocF ()) -> m String
|
|
||||||
|
|
||||||
throwError :: (Framed e m, MonadFile m) => String -> m a
|
|
|
@ -1,88 +0,0 @@
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
-- | Functions for manipulating nix strings.
|
|
||||||
module Nix.StringOperations where
|
|
||||||
|
|
||||||
import Data.List (intercalate)
|
|
||||||
import Data.Monoid ((<>))
|
|
||||||
import Data.Text (Text)
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import Data.Tuple (swap)
|
|
||||||
import Nix.Expr
|
|
||||||
|
|
||||||
-- | Merge adjacent 'Plain' values with 'mappend'.
|
|
||||||
mergePlain :: Monoid v => [Antiquoted v r] -> [Antiquoted v r]
|
|
||||||
mergePlain [] = []
|
|
||||||
mergePlain (Plain a: Plain b: xs) = mergePlain (Plain (a <> b) : xs)
|
|
||||||
mergePlain (x:xs) = x : mergePlain xs
|
|
||||||
|
|
||||||
-- | Remove 'Plain' values equal to 'mempty', as they don't have any
|
|
||||||
-- informational content.
|
|
||||||
removePlainEmpty :: (Eq v, Monoid v) => [Antiquoted v r] -> [Antiquoted v r]
|
|
||||||
removePlainEmpty = filter f where
|
|
||||||
f (Plain x) = x /= mempty
|
|
||||||
f _ = True
|
|
||||||
|
|
||||||
-- | Equivalent to case splitting on 'Antiquoted' strings.
|
|
||||||
runAntiquoted :: (v -> a) -> (r -> a) -> Antiquoted v r -> a
|
|
||||||
runAntiquoted f _ (Plain v) = f v
|
|
||||||
runAntiquoted _ f (Antiquoted r) = f r
|
|
||||||
|
|
||||||
-- | Split a stream representing a string with antiquotes on line breaks.
|
|
||||||
splitLines :: [Antiquoted Text r] -> [[Antiquoted Text r]]
|
|
||||||
splitLines = uncurry (flip (:)) . go where
|
|
||||||
go (Plain t : xs) = (Plain l :) <$> foldr f (go xs) ls where
|
|
||||||
(l : ls) = T.split (=='\n') t
|
|
||||||
f prefix (finished, current) = ((Plain prefix : current) : finished, [])
|
|
||||||
go (Antiquoted a : xs) = (Antiquoted a :) <$> go xs
|
|
||||||
go [] = ([],[])
|
|
||||||
|
|
||||||
-- | Join a stream of strings containing antiquotes again. This is the inverse
|
|
||||||
-- of 'splitLines'.
|
|
||||||
unsplitLines :: [[Antiquoted Text r]] -> [Antiquoted Text r]
|
|
||||||
unsplitLines = intercalate [Plain "\n"]
|
|
||||||
|
|
||||||
-- | Form an indented string by stripping spaces equal to the minimal indent.
|
|
||||||
stripIndent :: [Antiquoted Text r] -> NString r
|
|
||||||
stripIndent [] = Indented []
|
|
||||||
stripIndent xs =
|
|
||||||
Indented . removePlainEmpty . mergePlain . unsplitLines $ ls'
|
|
||||||
where
|
|
||||||
ls = stripEmptyOpening $ splitLines xs
|
|
||||||
ls' = map (dropSpaces minIndent) ls
|
|
||||||
|
|
||||||
minIndent = case stripEmptyLines ls of
|
|
||||||
[] -> 0
|
|
||||||
nonEmptyLs -> minimum $ map (countSpaces . mergePlain) nonEmptyLs
|
|
||||||
|
|
||||||
stripEmptyLines = filter $ \case
|
|
||||||
[Plain t] -> not $ T.null $ T.strip t
|
|
||||||
_ -> True
|
|
||||||
|
|
||||||
stripEmptyOpening ([Plain t]:ts) | T.null (T.strip t) = ts
|
|
||||||
stripEmptyOpening ts = ts
|
|
||||||
|
|
||||||
countSpaces (Antiquoted _:_) = 0
|
|
||||||
countSpaces (Plain t : _) = T.length . T.takeWhile (== ' ') $ t
|
|
||||||
countSpaces [] = 0
|
|
||||||
|
|
||||||
dropSpaces 0 x = x
|
|
||||||
dropSpaces n (Plain t : cs) = Plain (T.drop n t) : cs
|
|
||||||
dropSpaces _ _ = error "stripIndent: impossible"
|
|
||||||
|
|
||||||
escapeCodes :: [(Char, Char)]
|
|
||||||
escapeCodes =
|
|
||||||
[ ('\n', 'n' )
|
|
||||||
, ('\r', 'r' )
|
|
||||||
, ('\t', 't' )
|
|
||||||
, ('\\', '\\')
|
|
||||||
, ('$' , '$' )
|
|
||||||
, ('"', '"')
|
|
||||||
]
|
|
||||||
|
|
||||||
fromEscapeCode :: Char -> Maybe Char
|
|
||||||
fromEscapeCode = (`lookup` map swap escapeCodes)
|
|
||||||
|
|
||||||
toEscapeCode :: Char -> Maybe Char
|
|
||||||
toEscapeCode = (`lookup` escapeCodes)
|
|
36
Nix/TH.hs
36
Nix/TH.hs
|
@ -1,36 +0,0 @@
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
|
|
||||||
{-# OPTIONS_GHC -Wno-missing-fields #-}
|
|
||||||
|
|
||||||
module Nix.TH where
|
|
||||||
|
|
||||||
import Data.Fix
|
|
||||||
import Data.Generics.Aliases
|
|
||||||
import Data.Set (Set)
|
|
||||||
import qualified Data.Set as Set
|
|
||||||
import qualified Data.Text as Text
|
|
||||||
import Language.Haskell.TH
|
|
||||||
import Language.Haskell.TH.Quote
|
|
||||||
import Nix.Expr
|
|
||||||
import Nix.Parser
|
|
||||||
|
|
||||||
quoteExprExp :: String -> ExpQ
|
|
||||||
quoteExprExp s = do
|
|
||||||
expr <- case parseNixString s of
|
|
||||||
Failure err -> fail $ show err
|
|
||||||
Success e -> return e
|
|
||||||
dataToExpQ (const Nothing `extQ` metaExp (freeVars expr)) expr
|
|
||||||
|
|
||||||
freeVars :: NExpr -> Set VarName
|
|
||||||
freeVars = error "NYI: Implement an evaluator to find free variables"
|
|
||||||
|
|
||||||
metaExp :: Set VarName -> NExpr -> Maybe ExpQ
|
|
||||||
metaExp fvs (Fix (NSym x)) | x `Set.member` fvs =
|
|
||||||
Just [| toExpr $(varE (mkName (Text.unpack x))) |]
|
|
||||||
metaExp _ _ = Nothing
|
|
||||||
|
|
||||||
nix :: QuasiQuoter
|
|
||||||
nix = QuasiQuoter
|
|
||||||
{ quoteExp = quoteExprExp
|
|
||||||
}
|
|
69
Nix/Thunk.hs
69
Nix/Thunk.hs
|
@ -1,69 +0,0 @@
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE TupleSections #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
|
|
||||||
module Nix.Thunk where
|
|
||||||
|
|
||||||
import {-# SOURCE #-} Nix.Stack
|
|
||||||
|
|
||||||
data Deferred m v
|
|
||||||
= Deferred (m v)
|
|
||||||
| Computed v
|
|
||||||
|
|
||||||
class Monad m => MonadVar m where
|
|
||||||
type Var m :: * -> *
|
|
||||||
newVar :: a -> m (Var m a)
|
|
||||||
readVar :: Var m a -> m a
|
|
||||||
writeVar :: Var m a -> a -> m ()
|
|
||||||
atomicModifyVar :: Var m a -> (a -> (a, b)) -> m b
|
|
||||||
|
|
||||||
data Thunk m v
|
|
||||||
= Value v
|
|
||||||
| Action (m v)
|
|
||||||
| Thunk (Var m Bool) (Var m (Deferred m v))
|
|
||||||
|
|
||||||
valueRef :: v -> Thunk m v
|
|
||||||
valueRef = Value
|
|
||||||
|
|
||||||
buildRepeatingThunk :: m v -> Thunk m v
|
|
||||||
buildRepeatingThunk = Action
|
|
||||||
|
|
||||||
buildThunk :: MonadVar m => m v -> m (Thunk m v)
|
|
||||||
buildThunk action =
|
|
||||||
Thunk <$> newVar False <*> newVar (Deferred action)
|
|
||||||
|
|
||||||
forceThunk :: (Framed e m, MonadFile m, MonadVar m)
|
|
||||||
=> Thunk m v -> (v -> m r) -> m r
|
|
||||||
forceThunk (Value ref) k = k ref
|
|
||||||
forceThunk (Action ref) k = k =<< ref
|
|
||||||
forceThunk (Thunk active ref) k = do
|
|
||||||
eres <- readVar ref
|
|
||||||
case eres of
|
|
||||||
Computed value -> k value
|
|
||||||
Deferred action -> do
|
|
||||||
nowActive <- atomicModifyVar active (True,)
|
|
||||||
if nowActive
|
|
||||||
then throwError "<<loop>>"
|
|
||||||
else do
|
|
||||||
value <- action
|
|
||||||
writeVar ref (Computed value)
|
|
||||||
_ <- atomicModifyVar active (False,)
|
|
||||||
k value
|
|
||||||
|
|
||||||
forceEffects :: (Framed e m, MonadFile m, MonadVar m)
|
|
||||||
=> Thunk m v -> (v -> m r) -> m r
|
|
||||||
forceEffects (Value ref) k = k ref
|
|
||||||
forceEffects (Action ref) k = k =<< ref
|
|
||||||
forceEffects (Thunk active ref) k = do
|
|
||||||
nowActive <- atomicModifyVar active (True,)
|
|
||||||
if nowActive
|
|
||||||
then return $ error "forceEffects: a value was expected"
|
|
||||||
else do
|
|
||||||
eres <- readVar ref
|
|
||||||
case eres of
|
|
||||||
Computed value -> k value
|
|
||||||
Deferred action -> do
|
|
||||||
value <- action
|
|
||||||
writeVar ref (Computed value)
|
|
||||||
_ <- atomicModifyVar active (False,)
|
|
||||||
k value
|
|
87
Nix/Utils.hs
87
Nix/Utils.hs
|
@ -1,87 +0,0 @@
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE RankNTypes #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
|
|
||||||
module Nix.Utils (module Nix.Utils, module X) where
|
|
||||||
|
|
||||||
import Control.Applicative
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.Fix
|
|
||||||
import Data.Fix
|
|
||||||
import Data.Functor.Identity
|
|
||||||
import Data.Monoid (Endo)
|
|
||||||
|
|
||||||
-- #define ENABLE_TRACING 1
|
|
||||||
#if ENABLE_TRACING
|
|
||||||
import Debug.Trace as X
|
|
||||||
#else
|
|
||||||
import Prelude as X
|
|
||||||
trace :: String -> a -> a
|
|
||||||
trace = const id
|
|
||||||
traceM :: Monad m => String -> m ()
|
|
||||||
traceM = const (return ())
|
|
||||||
#endif
|
|
||||||
|
|
||||||
type DList a = Endo [a]
|
|
||||||
|
|
||||||
(&) :: a -> (a -> c) -> c
|
|
||||||
(&) = flip ($)
|
|
||||||
|
|
||||||
(<&>) :: Functor f => f a -> (a -> c) -> f c
|
|
||||||
(<&>) = flip (<$>)
|
|
||||||
|
|
||||||
(??) :: Functor f => f (a -> b) -> a -> f b
|
|
||||||
fab ?? a = fmap ($ a) fab
|
|
||||||
|
|
||||||
loeb :: Functor f => f (f a -> a) -> f a
|
|
||||||
loeb x = go where go = fmap ($ go) x
|
|
||||||
|
|
||||||
loebM :: (MonadFix m, Traversable t) => t (t a -> m a) -> m (t a)
|
|
||||||
loebM f = mfix $ \a -> mapM ($ a) f
|
|
||||||
|
|
||||||
para :: (a -> [a] -> b -> b) -> b -> [a] -> b
|
|
||||||
para f base = h where
|
|
||||||
h [] = base
|
|
||||||
h (x:xs) = f x xs (h xs)
|
|
||||||
|
|
||||||
paraM :: Monad m => (a -> [a] -> b -> m b) -> b -> [a] -> m b
|
|
||||||
paraM f base = h where
|
|
||||||
h [] = return base
|
|
||||||
h (x:xs) = f x xs =<< h xs
|
|
||||||
|
|
||||||
transport :: Functor g => (forall x. f x -> g x) -> Fix f -> Fix g
|
|
||||||
transport f (Fix x) = Fix $ fmap (transport f) (f x)
|
|
||||||
|
|
||||||
-- | adi is Abstracting Definitional Interpreters:
|
|
||||||
--
|
|
||||||
-- https://arxiv.org/abs/1707.04755
|
|
||||||
--
|
|
||||||
-- Essentially, it does for evaluation what recursion schemes do for
|
|
||||||
-- representation: allows threading layers through existing structure, only
|
|
||||||
-- in this case through behavior.
|
|
||||||
adi :: Traversable t
|
|
||||||
=> (t a -> a)
|
|
||||||
-> ((Fix t -> a) -> Fix t -> a)
|
|
||||||
-> Fix t -> a
|
|
||||||
adi f g = g (f . fmap (adi f g) . unFix)
|
|
||||||
|
|
||||||
adiM :: (Traversable t, Monad m)
|
|
||||||
=> (t a -> m a)
|
|
||||||
-> ((Fix t -> m a) -> Fix t -> m a)
|
|
||||||
-> Fix t -> m a
|
|
||||||
adiM f g = g ((f <=< traverse (adiM f g)) . unFix)
|
|
||||||
|
|
||||||
type MonoLens a b = forall f. Functor f => (b -> f b) -> a -> f a
|
|
||||||
|
|
||||||
view :: MonoLens a b -> a -> b
|
|
||||||
view l = getConst . l Const
|
|
||||||
|
|
||||||
set :: MonoLens a b -> b -> a -> a
|
|
||||||
set l b = runIdentity . l (\_ -> Identity b)
|
|
||||||
|
|
||||||
over :: MonoLens a b -> (b -> b) -> a -> a
|
|
||||||
over l f = runIdentity . l (Identity . f)
|
|
||||||
|
|
||||||
class Has a b where
|
|
||||||
hasLens :: MonoLens a b
|
|
108
Nix/Value.hs
108
Nix/Value.hs
|
@ -1,108 +0,0 @@
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE ConstraintKinds #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
|
|
||||||
module Nix.Value where
|
|
||||||
|
|
||||||
import Data.Coerce
|
|
||||||
import Data.Fix
|
|
||||||
import Data.HashMap.Lazy (HashMap)
|
|
||||||
import Data.Monoid (appEndo)
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Data.Typeable (Typeable)
|
|
||||||
import GHC.Generics
|
|
||||||
import Nix.Atoms
|
|
||||||
import Nix.Expr.Types
|
|
||||||
import Nix.Parser.Library (Delta(..))
|
|
||||||
import Nix.Scope
|
|
||||||
import {-# SOURCE #-} Nix.Stack
|
|
||||||
import Nix.Thunk
|
|
||||||
import Nix.Utils
|
|
||||||
|
|
||||||
newtype NThunk m = NThunk (Thunk m (NValue m))
|
|
||||||
|
|
||||||
thunk :: MonadVar m => m (NValue m) -> m (NThunk m)
|
|
||||||
thunk = fmap coerce . buildThunk
|
|
||||||
|
|
||||||
repeatingThunk :: MonadVar m => m (NValue m) -> NThunk m
|
|
||||||
repeatingThunk = coerce . buildRepeatingThunk
|
|
||||||
|
|
||||||
force :: (Framed e m, MonadFile m, MonadVar m)
|
|
||||||
=> NThunk m -> (NValue m -> m r) -> m r
|
|
||||||
force = forceThunk . coerce
|
|
||||||
|
|
||||||
valueThunk :: forall m. NValue m -> NThunk m
|
|
||||||
valueThunk = coerce . valueRef @_ @m
|
|
||||||
|
|
||||||
-- | An 'NValue' is the most reduced form of an 'NExpr' after evaluation
|
|
||||||
-- is completed.
|
|
||||||
data NValueF m r
|
|
||||||
= NVConstant NAtom
|
|
||||||
-- | A string has a value and a context, which can be used to record what a
|
|
||||||
-- string has been build from
|
|
||||||
| NVStr Text (DList Text)
|
|
||||||
| NVList [r]
|
|
||||||
| NVSet (HashMap Text r) (HashMap Text Delta)
|
|
||||||
| NVClosure (Scopes m r) (Params (m r)) (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.
|
|
||||||
| NVLiteralPath FilePath
|
|
||||||
| NVEnvPath FilePath
|
|
||||||
| NVBuiltin String (NThunk m -> m (NValue m))
|
|
||||||
-- ^ 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)
|
|
||||||
|
|
||||||
-- | An 'NValueNF' is a fully evaluated value in normal form. An 'NValue m' is
|
|
||||||
-- a value in head normal form, where only the "top layer" has been
|
|
||||||
-- evaluated. An action of type 'm (NValue m)' is a pending evualation that
|
|
||||||
-- has yet to be performed. An 'NThunk m' is either a pending evaluation, or
|
|
||||||
-- a value in head normal form. A 'ValueSet' is a set of mappings from keys
|
|
||||||
-- to thunks.
|
|
||||||
|
|
||||||
type NValueNF m = Fix (NValueF m) -- normal form
|
|
||||||
type NValue m = NValueF m (NThunk m) -- head normal form
|
|
||||||
type ValueSet m = HashMap Text (NThunk m)
|
|
||||||
|
|
||||||
instance Show (NThunk m) where
|
|
||||||
show (NThunk (Value v)) = show v
|
|
||||||
show (NThunk _) = "<thunk>"
|
|
||||||
|
|
||||||
instance Show f => Show (NValueF m f) where
|
|
||||||
showsPrec = flip go where
|
|
||||||
go (NVConstant atom) = showsCon1 "NVConstant" atom
|
|
||||||
go (NVStr text context) = showsCon2 "NVStr" text (appEndo context [])
|
|
||||||
go (NVList list) = showsCon1 "NVList" list
|
|
||||||
go (NVSet attrs _) = showsCon1 "NVSet" attrs
|
|
||||||
go (NVClosure s r _) = showsCon2 "NVClosure" s (() <$ r)
|
|
||||||
go (NVLiteralPath p) = showsCon1 "NVLiteralPath" p
|
|
||||||
go (NVEnvPath p) = showsCon1 "NVEnvPath" p
|
|
||||||
go (NVBuiltin name _) = showsCon1 "NVBuiltin" name
|
|
||||||
|
|
||||||
showsCon1 :: Show a => String -> a -> Int -> String -> String
|
|
||||||
showsCon1 con a d =
|
|
||||||
showParen (d > 10) $ showString (con ++ " ") . showsPrec 11 a
|
|
||||||
|
|
||||||
showsCon2 :: (Show a, Show b)
|
|
||||||
=> String -> a -> b -> Int -> String -> String
|
|
||||||
showsCon2 con a b d =
|
|
||||||
showParen (d > 10)
|
|
||||||
$ showString (con ++ " ")
|
|
||||||
. showsPrec 11 a
|
|
||||||
. showString " "
|
|
||||||
. showsPrec 11 b
|
|
58
Nix/XML.hs
58
Nix/XML.hs
|
@ -1,58 +0,0 @@
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
|
|
||||||
module Nix.XML where
|
|
||||||
|
|
||||||
import Data.Fix
|
|
||||||
import qualified Data.HashMap.Lazy as M
|
|
||||||
import qualified Data.HashMap.Strict.InsOrd as OM
|
|
||||||
import Data.List
|
|
||||||
import Data.Ord
|
|
||||||
import qualified Data.Text as Text
|
|
||||||
import Nix.Atoms
|
|
||||||
import Nix.Expr.Types
|
|
||||||
import Nix.Value
|
|
||||||
import Text.XML.Light
|
|
||||||
|
|
||||||
toXML :: Functor m => NValueNF m -> String
|
|
||||||
toXML = (.) ((++ "\n") .
|
|
||||||
("<?xml version='1.0' encoding='utf-8'?>\n" ++) .
|
|
||||||
ppElement .
|
|
||||||
(\e -> Element (unqual "expr") [] [Elem e] Nothing))
|
|
||||||
$ cata
|
|
||||||
$ \case
|
|
||||||
NVConstant a -> case a of
|
|
||||||
NInt n -> mkElem "int" "value" (show n)
|
|
||||||
NFloat f -> mkElem "float" "value" (show f)
|
|
||||||
NBool b -> mkElem "bool" "value" (if b then "true" else "false")
|
|
||||||
NNull -> Element (unqual "null") [] [] Nothing
|
|
||||||
NUri u -> mkElem "uri" "value" (Text.unpack u)
|
|
||||||
|
|
||||||
NVStr t _ -> mkElem "string" "value" (Text.unpack t)
|
|
||||||
NVList l -> Element (unqual "list") [] (Elem <$> l) Nothing
|
|
||||||
|
|
||||||
NVSet s _ -> Element (unqual "attrs") []
|
|
||||||
(map (\(k, v) -> Elem (Element (unqual "attr")
|
|
||||||
[Attr (unqual "name") (Text.unpack k)]
|
|
||||||
[Elem v] Nothing))
|
|
||||||
(sortBy (comparing fst) $ M.toList s)) Nothing
|
|
||||||
|
|
||||||
NVClosure _ p _ ->
|
|
||||||
Element (unqual "function") [] (paramsXML p) Nothing
|
|
||||||
NVLiteralPath fp -> mkElem "path" "value" fp
|
|
||||||
NVEnvPath p -> mkElem "path" "value" p
|
|
||||||
NVBuiltin name _ -> mkElem "function" "name" name
|
|
||||||
|
|
||||||
mkElem :: String -> String -> String -> Element
|
|
||||||
mkElem n a v = Element (unqual n) [Attr (unqual a) v] [] Nothing
|
|
||||||
|
|
||||||
paramsXML :: Params r -> [Content]
|
|
||||||
paramsXML (Param name) =
|
|
||||||
[Elem $ mkElem "varpat" "name" (Text.unpack name)]
|
|
||||||
paramsXML (ParamSet s b mname) =
|
|
||||||
[Elem $ Element (unqual "attrspat") (battr ++ nattr) (paramSetXML s) Nothing]
|
|
||||||
where
|
|
||||||
battr = [ Attr (unqual "ellipsis") "1" | b ]
|
|
||||||
nattr = maybe [] ((:[]) . Attr (unqual "name") . Text.unpack) mname
|
|
||||||
|
|
||||||
paramSetXML :: ParamSet r -> [Content]
|
|
||||||
paramSetXML m = map (\(k,_) -> Elem $ mkElem "attr" "name" (Text.unpack k)) $ OM.toList m
|
|
278
hnix.cabal
278
hnix.cabal
|
@ -1,153 +1,183 @@
|
||||||
Name: hnix
|
-- This file has been generated from package.yaml by hpack version 0.27.0.
|
||||||
Version: 0.5.0
|
--
|
||||||
Synopsis: Haskell implementation of the Nix language
|
-- see: https://github.com/sol/hpack
|
||||||
Description:
|
--
|
||||||
Haskell implementation of the Nix language.
|
-- hash: e53f006b5a943cc09b8c3e9aa5619e2f36b25a9df96c157b6ab0e46c170fde0f
|
||||||
|
|
||||||
License: BSD3
|
name: hnix
|
||||||
License-file: LICENSE
|
version: 0.5.0
|
||||||
Author: John Wiegley
|
synopsis: Haskell implementation of the Nix language
|
||||||
Maintainer: johnw@newartisans.com
|
description: Haskell implementation of the Nix language.
|
||||||
Category: Data, Nix
|
category: System, Data, Nix
|
||||||
Build-type: Simple
|
homepage: https://github.com/jwiegley/hnix#readme
|
||||||
Cabal-version: >=1.10
|
bug-reports: https://github.com/jwiegley/hnix/issues
|
||||||
Homepage: http://github.com/jwiegley/hnix
|
author: John Wiegley
|
||||||
|
maintainer: johnw@newartisans.com
|
||||||
|
license: BSD3
|
||||||
|
license-file: LICENSE
|
||||||
|
build-type: Simple
|
||||||
|
cabal-version: >= 1.10
|
||||||
|
|
||||||
Extra-source-files: data/*.nix
|
extra-source-files:
|
||||||
|
README.md
|
||||||
|
|
||||||
Flag Parsec
|
source-repository head
|
||||||
Description: Use parsec instead of Trifecta
|
type: git
|
||||||
Default: False
|
location: https://github.com/jwiegley/hnix
|
||||||
|
|
||||||
Library
|
flag parsec
|
||||||
Default-language: Haskell2010
|
description: Use parsec instead of Trifecta
|
||||||
Exposed-modules:
|
manual: True
|
||||||
Nix
|
default: False
|
||||||
Nix.Atoms
|
|
||||||
Nix.Builtins
|
library
|
||||||
Nix.Eval
|
exposed-modules:
|
||||||
Nix.Expr
|
Nix
|
||||||
Nix.Expr.Types
|
Nix.Atoms
|
||||||
Nix.Expr.Types.Annotated
|
Nix.Builtins
|
||||||
Nix.Lint
|
Nix.Eval
|
||||||
Nix.Monad
|
Nix.Expr
|
||||||
Nix.Monad.Instance
|
Nix.Expr.Shorthands
|
||||||
Nix.Parser
|
Nix.Expr.Types
|
||||||
Nix.Parser.Operators
|
Nix.Expr.Types.Annotated
|
||||||
Nix.Pretty
|
Nix.Lint
|
||||||
Nix.Scope
|
Nix.Monad
|
||||||
Nix.Stack
|
Nix.Monad.Instance
|
||||||
Nix.StringOperations
|
Nix.Parser
|
||||||
Nix.TH
|
Nix.Parser.Library
|
||||||
Nix.Thunk
|
Nix.Parser.Operators
|
||||||
Nix.Utils
|
Nix.Pretty
|
||||||
Nix.Value
|
Nix.Scope
|
||||||
Nix.XML
|
Nix.Stack
|
||||||
Other-modules:
|
Nix.StringOperations
|
||||||
Nix.Expr.Shorthands
|
Nix.TH
|
||||||
Nix.Parser.Library
|
Nix.Thunk
|
||||||
Build-depends:
|
Nix.Utils
|
||||||
base >= 4.9 && < 5
|
Nix.Value
|
||||||
, aeson
|
Nix.XML
|
||||||
|
other-modules:
|
||||||
|
Paths_hnix
|
||||||
|
hs-source-dirs:
|
||||||
|
src
|
||||||
|
ghc-options: -Wall
|
||||||
|
build-depends:
|
||||||
|
aeson
|
||||||
, ansi-wl-pprint
|
, ansi-wl-pprint
|
||||||
, array >= 0.4 && < 0.6
|
, array >=0.4 && <0.6
|
||||||
|
, base >=4.9 && <5
|
||||||
, base16-bytestring
|
, base16-bytestring
|
||||||
|
, bytestring
|
||||||
, containers
|
, containers
|
||||||
, cryptohash
|
, cryptohash
|
||||||
, deriving-compat >= 0.3 && < 0.5
|
|
||||||
, text
|
|
||||||
, bytestring
|
|
||||||
, monadlist
|
|
||||||
, mtl
|
|
||||||
, transformers
|
|
||||||
, parsers >= 0.10
|
|
||||||
, insert-ordered-containers >= 0.2.2
|
|
||||||
, unordered-containers >= 0.2.9 && < 0.3
|
|
||||||
, data-fix
|
, data-fix
|
||||||
, deepseq
|
, deepseq
|
||||||
, exceptions
|
, deriving-compat >=0.3 && <0.5
|
||||||
, insert-ordered-containers >= 0.2.2 && < 0.3
|
|
||||||
, process
|
|
||||||
, directory
|
, directory
|
||||||
|
, exceptions
|
||||||
, filepath
|
, filepath
|
||||||
, scientific
|
, insert-ordered-containers >=0.2.2 && <0.3
|
||||||
, semigroups >= 0.18 && < 0.19
|
, monadlist
|
||||||
, split
|
, mtl
|
||||||
, template-haskell
|
, parsers >=0.10
|
||||||
|
, process
|
||||||
, regex-tdfa
|
, regex-tdfa
|
||||||
, regex-tdfa-text
|
, regex-tdfa-text
|
||||||
, these
|
, scientific
|
||||||
, unix
|
, semigroups >=0.18 && <0.19
|
||||||
|
, split
|
||||||
, syb
|
, syb
|
||||||
|
, template-haskell
|
||||||
|
, text
|
||||||
|
, these
|
||||||
|
, transformers
|
||||||
|
, unix
|
||||||
|
, unordered-containers >=0.2.9 && <0.3
|
||||||
, vector
|
, vector
|
||||||
, xml
|
, xml
|
||||||
if flag(parsec)
|
if flag(parsec)
|
||||||
Cpp-options: -DUSE_PARSEC
|
cpp-options: -DUSE_PARSEC
|
||||||
Build-depends: parsec
|
build-depends:
|
||||||
|
parsec
|
||||||
else
|
else
|
||||||
Build-depends: trifecta
|
build-depends:
|
||||||
ghc-options: -Wall
|
trifecta
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
Executable hnix
|
executable hnix
|
||||||
Default-language: Haskell2010
|
main-is: Main.hs
|
||||||
Main-is: Main.hs
|
other-modules:
|
||||||
Hs-source-dirs: main
|
Paths_hnix
|
||||||
Build-depends:
|
hs-source-dirs:
|
||||||
base >= 4.3 && < 5
|
main
|
||||||
, hnix
|
ghc-options: -Wall
|
||||||
|
build-depends:
|
||||||
|
ansi-wl-pprint
|
||||||
|
, base >=4.9 && <5
|
||||||
, containers
|
, containers
|
||||||
, ansi-wl-pprint
|
|
||||||
, data-fix
|
, data-fix
|
||||||
, deepseq
|
, deepseq
|
||||||
|
, hnix
|
||||||
|
, insert-ordered-containers >=0.2.2 && <0.3
|
||||||
|
, mtl
|
||||||
, optparse-applicative
|
, optparse-applicative
|
||||||
, text
|
|
||||||
, template-haskell
|
, template-haskell
|
||||||
, transformers
|
|
||||||
, filepath
|
|
||||||
Ghc-options: -Wall
|
|
||||||
|
|
||||||
Test-suite hnix-tests
|
|
||||||
Type: exitcode-stdio-1.0
|
|
||||||
Hs-source-dirs: tests
|
|
||||||
Default-language: Haskell2010
|
|
||||||
Main-is: Main.hs
|
|
||||||
Other-modules:
|
|
||||||
ParserTests
|
|
||||||
EvalTests
|
|
||||||
PrettyTests
|
|
||||||
NixLanguageTests
|
|
||||||
Build-depends:
|
|
||||||
base >= 4.3 && < 5
|
|
||||||
, containers
|
|
||||||
, text
|
, text
|
||||||
|
, transformers
|
||||||
|
, unordered-containers >=0.2.9 && <0.3
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
test-suite hnix-tests
|
||||||
|
type: exitcode-stdio-1.0
|
||||||
|
main-is: Main.hs
|
||||||
|
other-modules:
|
||||||
|
ParserTests
|
||||||
|
EvalTests
|
||||||
|
PrettyTests
|
||||||
|
NixLanguageTests
|
||||||
|
hs-source-dirs:
|
||||||
|
tests
|
||||||
|
ghc-options: -Wall
|
||||||
|
build-depends:
|
||||||
|
Glob
|
||||||
|
, ansi-wl-pprint
|
||||||
|
, base >=4.9 && <5
|
||||||
|
, containers
|
||||||
|
, data-fix
|
||||||
|
, filepath
|
||||||
|
, hnix
|
||||||
|
, insert-ordered-containers >=0.2.2 && <0.3
|
||||||
|
, interpolate
|
||||||
|
, mtl
|
||||||
|
, split
|
||||||
|
, tasty
|
||||||
|
, tasty-hunit
|
||||||
|
, tasty-th
|
||||||
|
, template-haskell
|
||||||
|
, text
|
||||||
|
, transformers
|
||||||
|
, unix
|
||||||
|
, unordered-containers >=0.2.9 && <0.3
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
benchmark hnix-benchmarks
|
||||||
|
type: exitcode-stdio-1.0
|
||||||
|
main-is: Main.hs
|
||||||
|
other-modules:
|
||||||
|
ParserBench
|
||||||
|
hs-source-dirs:
|
||||||
|
benchmarks
|
||||||
|
ghc-options: -Wall
|
||||||
|
build-depends:
|
||||||
|
ansi-wl-pprint
|
||||||
|
, base >=4.9 && <5
|
||||||
|
, containers
|
||||||
|
, criterion
|
||||||
, data-fix
|
, data-fix
|
||||||
, hnix
|
, hnix
|
||||||
, tasty
|
, insert-ordered-containers >=0.2.2 && <0.3
|
||||||
, tasty-th
|
, mtl
|
||||||
, tasty-hunit
|
, template-haskell
|
||||||
, directory
|
|
||||||
, Glob
|
|
||||||
, filepath
|
|
||||||
, split
|
|
||||||
, transformers
|
|
||||||
, interpolate
|
|
||||||
, insert-ordered-containers
|
|
||||||
, unordered-containers
|
|
||||||
|
|
||||||
Benchmark hnix-benchmarks
|
|
||||||
Type: exitcode-stdio-1.0
|
|
||||||
Hs-source-dirs: benchmarks
|
|
||||||
Default-language: Haskell2010
|
|
||||||
Main-is: Main.hs
|
|
||||||
Other-modules:
|
|
||||||
ParserBench
|
|
||||||
Build-depends:
|
|
||||||
base >= 4.3 && < 5
|
|
||||||
, containers
|
|
||||||
, text
|
, text
|
||||||
, hnix
|
, transformers
|
||||||
, criterion
|
, unordered-containers >=0.2.9 && <0.3
|
||||||
|
default-language: Haskell2010
|
||||||
source-repository head
|
|
||||||
type: git
|
|
||||||
location: git://github.com/jwiegley/hnix.git
|
|
||||||
|
|
109
package.yaml
Normal file
109
package.yaml
Normal file
|
@ -0,0 +1,109 @@
|
||||||
|
name: hnix
|
||||||
|
version: 0.5.0
|
||||||
|
synopsis: Haskell implementation of the Nix language
|
||||||
|
github: jwiegley/hnix
|
||||||
|
author: John Wiegley
|
||||||
|
maintainer: johnw@newartisans.com
|
||||||
|
category: System, Data, Nix
|
||||||
|
license: BSD3
|
||||||
|
|
||||||
|
description:
|
||||||
|
Haskell implementation of the Nix language.
|
||||||
|
|
||||||
|
extra-source-files:
|
||||||
|
- README.md
|
||||||
|
|
||||||
|
flags:
|
||||||
|
parsec:
|
||||||
|
description: Use parsec instead of Trifecta
|
||||||
|
manual: True
|
||||||
|
default: False
|
||||||
|
|
||||||
|
dependencies:
|
||||||
|
- base >= 4.9 && < 5
|
||||||
|
- ansi-wl-pprint
|
||||||
|
- containers
|
||||||
|
- data-fix
|
||||||
|
- insert-ordered-containers >= 0.2.2 && < 0.3
|
||||||
|
- mtl
|
||||||
|
- template-haskell
|
||||||
|
- text
|
||||||
|
- transformers
|
||||||
|
- unordered-containers >= 0.2.9 && < 0.3
|
||||||
|
|
||||||
|
ghc-options:
|
||||||
|
- -Wall
|
||||||
|
|
||||||
|
library:
|
||||||
|
source-dirs: src
|
||||||
|
dependencies:
|
||||||
|
- aeson
|
||||||
|
- ansi-wl-pprint
|
||||||
|
- array >= 0.4 && < 0.6
|
||||||
|
- base16-bytestring
|
||||||
|
- bytestring
|
||||||
|
- cryptohash
|
||||||
|
- deepseq
|
||||||
|
- deriving-compat >= 0.3 && < 0.5
|
||||||
|
- directory
|
||||||
|
- exceptions
|
||||||
|
- filepath
|
||||||
|
- monadlist
|
||||||
|
- parsers >= 0.10
|
||||||
|
- process
|
||||||
|
- regex-tdfa
|
||||||
|
- regex-tdfa-text
|
||||||
|
- scientific
|
||||||
|
- semigroups >= 0.18 && < 0.19
|
||||||
|
- split
|
||||||
|
- syb
|
||||||
|
- these
|
||||||
|
- unix
|
||||||
|
- vector
|
||||||
|
- xml
|
||||||
|
when:
|
||||||
|
- condition: flag(parsec)
|
||||||
|
then:
|
||||||
|
cpp-options: -DUSE_PARSEC
|
||||||
|
dependencies: parsec
|
||||||
|
else:
|
||||||
|
dependencies: trifecta
|
||||||
|
|
||||||
|
executables:
|
||||||
|
hnix:
|
||||||
|
source-dirs: main
|
||||||
|
main: Main.hs
|
||||||
|
dependencies:
|
||||||
|
- hnix
|
||||||
|
- deepseq
|
||||||
|
- optparse-applicative
|
||||||
|
|
||||||
|
tests:
|
||||||
|
hnix-tests:
|
||||||
|
source-dirs: tests
|
||||||
|
main: Main.hs
|
||||||
|
other-modules:
|
||||||
|
- ParserTests
|
||||||
|
- EvalTests
|
||||||
|
- PrettyTests
|
||||||
|
- NixLanguageTests
|
||||||
|
dependencies:
|
||||||
|
- hnix
|
||||||
|
- Glob
|
||||||
|
- filepath
|
||||||
|
- interpolate
|
||||||
|
- split
|
||||||
|
- tasty
|
||||||
|
- tasty-hunit
|
||||||
|
- tasty-th
|
||||||
|
- unix
|
||||||
|
|
||||||
|
benchmarks:
|
||||||
|
hnix-benchmarks:
|
||||||
|
source-dirs: benchmarks
|
||||||
|
main: Main.hs
|
||||||
|
other-modules:
|
||||||
|
- ParserBench
|
||||||
|
dependencies:
|
||||||
|
- hnix
|
||||||
|
- criterion
|
|
@ -5,8 +5,8 @@ import qualified EvalTests
|
||||||
import qualified NixLanguageTests
|
import qualified NixLanguageTests
|
||||||
import qualified ParserTests
|
import qualified ParserTests
|
||||||
import qualified PrettyTests
|
import qualified PrettyTests
|
||||||
import System.Directory
|
|
||||||
import System.Environment
|
import System.Environment
|
||||||
|
import System.Posix.Files
|
||||||
import Test.Tasty
|
import Test.Tasty
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
|
@ -15,7 +15,7 @@ main = do
|
||||||
langTestsEnv <- lookupEnv "LANGUAGE_TESTS"
|
langTestsEnv <- lookupEnv "LANGUAGE_TESTS"
|
||||||
let runLangTests = langTestsEnv == Just "yes"
|
let runLangTests = langTestsEnv == Just "yes"
|
||||||
when runLangTests $ do
|
when runLangTests $ do
|
||||||
exist <- doesDirectoryExist "data/nix/tests"
|
exist <- fileExist "data/nix/tests/local.mk"
|
||||||
unless exist $
|
unless exist $
|
||||||
errorWithoutStackTrace $ unlines
|
errorWithoutStackTrace $ unlines
|
||||||
[ "Directory data/nix does not have any files."
|
[ "Directory data/nix does not have any files."
|
||||||
|
|
Loading…
Reference in a new issue