picnoir
/
hnix
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Use hpack and move all the Nix sources into a src/ directory

This commit is contained in:
John Wiegley 2018-04-07 12:02:33 -07:00
parent d9047cc216
commit 443129315d
27 changed files with 265 additions and 4531 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

134
Nix.hs
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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
View File

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

235
Nix/Expr/Shorthands.hs
View File

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

255
Nix/Expr/Types.hs
View File

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

100
Nix/Expr/Types/Annotated.hs
View File

@ -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
View File

@ -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
View File

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

175
Nix/Monad/Instance.hs
View File

@ -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
View File

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

173
Nix/Parser/Library.hs
View File

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

82
Nix/Parser/Operators.hs
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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])

27
Nix/Stack.hs-boot
View File

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

88
Nix/StringOperations.hs
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -1,153 +1,183 @@
Name: hnix
Version: 0.5.0
Synopsis: Haskell implementation of the Nix language
Description:
Haskell implementation of the Nix language.
-- This file has been generated from package.yaml by hpack version 0.27.0.
--
-- see: https://github.com/sol/hpack
--
-- hash: e53f006b5a943cc09b8c3e9aa5619e2f36b25a9df96c157b6ab0e46c170fde0f
License: BSD3
License-file: LICENSE
Author: John Wiegley
Maintainer: johnw@newartisans.com
Category: Data, Nix
Build-type: Simple
Cabal-version: >=1.10
Homepage: http://github.com/jwiegley/hnix
name: hnix
version: 0.5.0
synopsis: Haskell implementation of the Nix language
description: Haskell implementation of the Nix language.
category: System, Data, Nix
homepage: https://github.com/jwiegley/hnix#readme
bug-reports: https://github.com/jwiegley/hnix/issues
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
Description: Use parsec instead of Trifecta
Default: False
source-repository head
type: git
location: https://github.com/jwiegley/hnix
Library
Default-language: Haskell2010
Exposed-modules:
Nix
Nix.Atoms
Nix.Builtins
Nix.Eval
Nix.Expr
Nix.Expr.Types
Nix.Expr.Types.Annotated
Nix.Lint
Nix.Monad
Nix.Monad.Instance
Nix.Parser
Nix.Parser.Operators
Nix.Pretty
Nix.Scope
Nix.Stack
Nix.StringOperations
Nix.TH
Nix.Thunk
Nix.Utils
Nix.Value
Nix.XML
Other-modules:
Nix.Expr.Shorthands
Nix.Parser.Library
Build-depends:
base >= 4.9 && < 5
, aeson
flag parsec
description: Use parsec instead of Trifecta
manual: True
default: False
library
exposed-modules:
Nix
Nix.Atoms
Nix.Builtins
Nix.Eval
Nix.Expr
Nix.Expr.Shorthands
Nix.Expr.Types
Nix.Expr.Types.Annotated
Nix.Lint
Nix.Monad
Nix.Monad.Instance
Nix.Parser
Nix.Parser.Library
Nix.Parser.Operators
Nix.Pretty
Nix.Scope
Nix.Stack
Nix.StringOperations
Nix.TH
Nix.Thunk
Nix.Utils
Nix.Value
Nix.XML
other-modules:
Paths_hnix
hs-source-dirs:
src
ghc-options: -Wall
build-depends:
aeson
, ansi-wl-pprint
, array >= 0.4 && < 0.6
, array >=0.4 && <0.6
, base >=4.9 && <5
, base16-bytestring
, bytestring
, containers
, 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
, deepseq
, exceptions
, insert-ordered-containers >= 0.2.2 && < 0.3
, process
, deriving-compat >=0.3 && <0.5
, directory
, exceptions
, filepath
, scientific
, semigroups >= 0.18 && < 0.19
, split
, template-haskell
, insert-ordered-containers >=0.2.2 && <0.3
, monadlist
, mtl
, parsers >=0.10
, process
, regex-tdfa
, regex-tdfa-text
, these
, unix
, scientific
, semigroups >=0.18 && <0.19
, split
, syb
, template-haskell
, text
, these
, transformers
, unix
, unordered-containers >=0.2.9 && <0.3
, vector
, xml
if flag(parsec)
Cpp-options: -DUSE_PARSEC
Build-depends: parsec
cpp-options: -DUSE_PARSEC
build-depends:
parsec
else
Build-depends: trifecta
ghc-options: -Wall
build-depends:
trifecta
default-language: Haskell2010
Executable hnix
Default-language: Haskell2010
Main-is: Main.hs
Hs-source-dirs: main
Build-depends:
base >= 4.3 && < 5
, hnix
executable hnix
main-is: Main.hs
other-modules:
Paths_hnix
hs-source-dirs:
main
ghc-options: -Wall
build-depends:
ansi-wl-pprint
, base >=4.9 && <5
, containers
, ansi-wl-pprint
, data-fix
, deepseq
, hnix
, insert-ordered-containers >=0.2.2 && <0.3
, mtl
, optparse-applicative
, text
, 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
, 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
, hnix
, tasty
, tasty-th
, tasty-hunit
, 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
, insert-ordered-containers >=0.2.2 && <0.3
, mtl
, template-haskell
, text
, hnix
, criterion
source-repository head
type: git
location: git://github.com/jwiegley/hnix.git
, transformers
, unordered-containers >=0.2.9 && <0.3
default-language: Haskell2010

109
package.yaml Normal file
View 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

4
tests/Main.hs
View File

@ -5,8 +5,8 @@ import qualified EvalTests
import qualified NixLanguageTests
import qualified ParserTests
import qualified PrettyTests
import System.Directory
import System.Environment
import System.Posix.Files
import Test.Tasty
main :: IO ()
@ -15,7 +15,7 @@ main = do
langTestsEnv <- lookupEnv "LANGUAGE_TESTS"
let runLangTests = langTestsEnv == Just "yes"
when runLangTests $ do
exist <- doesDirectoryExist "data/nix/tests"
exist <- fileExist "data/nix/tests/local.mk"
unless exist $
errorWithoutStackTrace $ unlines
[ "Directory data/nix does not have any files."