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

Merge branch 'master' into string_context_255

Browse source
This commit is contained in:
John Wiegley 2018-05-06 10:47:23 -07:00 committed by GitHub
parent c0acddaa1b 90a42c3c7d
commit f1faf50bcb
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
14 changed files with 328 additions and 68 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
hnix.cabal
View file

@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
-- hash: b50a1c4cf11872cb711f0ed200482f16620ea7754fe7bf8cf8892413d0231746
-- hash: 5eba5b1b4e2ae5297dcad048052e5bc02fc2f42aa37016fbea866ecbf3f4a380
name: hnix
version: 0.5.0
@ -104,6 +104,9 @@ library
, http-client
, http-client-tls
, http-types
, lens-family
, lens-family-core
, lens-family-th
, logict
, megaparsec
, monadlist
@ -176,6 +179,7 @@ test-suite hnix-tests
EvalTests
NixLanguageTests
ParserTests
PrettyParseTests
PrettyTests
TestCommon
Paths_hnix
@ -183,7 +187,9 @@ test-suite hnix-tests
tests
ghc-options: -Wall -threaded
build-depends:
Glob
Diff
, Glob
, QuickCheck
, ansi-wl-pprint
, base >=4.9 && <5
, bytestring
@ -194,15 +200,19 @@ test-suite hnix-tests
, directory
, exceptions
, filepath
, generic-random
, hnix
, interpolate
, megaparsec
, mtl
, optparse-applicative
, process
, quickcheck-instances
, serialise
, split
, tasty
, tasty-hunit
, tasty-quickcheck
, tasty-th
, template-haskell
, text

9
package.yaml
View file

@ -78,6 +78,9 @@ library:
- http-client
- http-client-tls
- haskeline
- lens-family
- lens-family-core
- lens-family-th
- logict
- megaparsec
- monadlist
@ -125,6 +128,12 @@ tests:
- tasty-hunit
- tasty-th
- unix
- QuickCheck
- quickcheck-instances
- generic-random
- Diff
- megaparsec
- tasty-quickcheck
benchmarks:
hnix-benchmarks:

19
src/Nix/Builtins.hs
View file

@ -279,9 +279,7 @@ unsafeGetAttrPos :: forall e m. MonadNix e m
=> m (NValue m) -> m (NValue m) -> m (NValue m)
unsafeGetAttrPos x y = x >>= \x' -> y >>= \y' -> case (x', y') of
(NVStr key _, NVSet _ apos) -> case M.lookup key apos of
Nothing ->
throwError $ ErrorCall $ "unsafeGetAttrPos: field '" ++ Text.unpack key
++ "' does not exist in attr set: " ++ show apos
Nothing -> pure $ nvConstant NNull
Just delta -> toValue delta
(x, y) -> throwError $ ErrorCall $ "Invalid types for builtin.unsafeGetAttrPos: "
++ show (x, y)
@ -536,7 +534,7 @@ seq_ a b = a >> b
deepSeq :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
deepSeq a b = do
-- We evaluate 'a' only for its effects, so data cycles are ignored.
_ <- normalFormBy (forceEffects . coerce . baseThunk) 0 =<< a
_ <- normalFormBy (forceEffects . coerce . _baseThunk) 0 =<< a
-- Then we evaluate the other argument to deepseq, thus this function
-- should always produce a result (unlike applying 'deepseq' on infinitely
@ -759,15 +757,10 @@ concatLists = fromValue @[NThunk m]
listToAttrs :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
listToAttrs = fromValue @[NThunk m] >=> \l ->
fmap (flip nvSet M.empty . M.fromList . reverse) $
forM l $ fromValue @(AttrSet (NThunk m)) >=> \s ->
case (M.lookup "name" s, M.lookup "value" s) of
(Just name, Just value) -> fromValue name <&> (, value)
_ -> throwError $ ErrorCall $
-- jww (2018-05-01): Rather than include the function name
-- in the message like this, we should add it as a frame
-- in `callFunc' before calling each builtin.
"builtins.listToAttrs: expected set with name and value, got"
++ show s
forM l $ fromValue @(AttrSet (NThunk m)) >=> \s -> do
name <- attrsetGet "name" s
val <- attrsetGet "value" s
fromValue name <&> (, val)
hashString :: MonadNix e m => Text -> Text -> Prim m Text
hashString algo s = Prim $ do

1
src/Nix/Eval.hs
View file

@ -100,6 +100,7 @@ type MonadNixEval e v t m =
data EvalFrame m v
= EvaluatingExpr (Scopes m v) NExprLoc
| ForcingExpr (Scopes m v) NExprLoc
| Calling String SrcSpan
deriving (Show, Typeable)
instance (Typeable m, Typeable v) => Exception (EvalFrame m v)

13
src/Nix/Exec.hs
View file

@ -97,7 +97,7 @@ nverr :: forall s e m a. (MonadNix e m, Exception s) => s -> m a
nverr = evalError @(NValue m)
currentPos :: forall e m. (MonadReader e m, Has e SrcSpan) => m SrcSpan
currentPos = asks (view @e @SrcSpan hasLens)
currentPos = asks (view hasLens)
wrapExprLoc :: SrcSpan -> NExprLocF r -> NExprLoc
wrapExprLoc span x = Fix (Fix (NSym_ span "<?>") <$ x)
@ -108,7 +108,7 @@ instance MonadNix e m => MonadThunk (NValue m) (NThunk m) m where
if thunks opts
then do
frames <- asks (view @_ @Frames hasLens)
frames :: Frames <- asks (view hasLens)
-- Gather the current evaluation context at the time of thunk
-- creation, and record it along with the thunk.
@ -241,14 +241,15 @@ instance MonadNix e m => MonadEval (NValue m) m where
evalError = throwError
infixl 1 `callFunc`
callFunc :: MonadNix e m => NValue m -> m (NValue m) -> m (NValue m)
callFunc :: forall e m. (MonadNix e m, Typeable m)
=> NValue m -> m (NValue m) -> m (NValue m)
callFunc fun arg = case fun of
NVClosure params f -> do
traceM $ "callFunc:NVFunction taking " ++ show params
f arg
NVBuiltin name f -> do
traceM $ "callFunc:NVBuiltin " ++ name
f arg
span <- currentPos
withFrame Info (Calling @m @(NThunk m) name span) $ f arg
s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do
traceM "callFunc:__functor"
force f $ (`callFunc` pure s) >=> (`callFunc` arg)
@ -611,7 +612,7 @@ instance (MonadFix m, MonadCatch m, MonadIO m, Alternative m,
if status /= 200
then throwError $ ErrorCall $
"fail, got " ++ show status ++ " when fetching url:" ++ urlstr
else do
else -- do
-- let bstr = responseBody response
-- liftIO $ print bstr
throwError $ ErrorCall $

53
src/Nix/Expr/Types.hs
View file

@ -8,24 +8,29 @@
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
-- | The nix expression type and supporting types.
module Nix.Expr.Types where
import Codec.Serialise (Serialise)
import qualified Codec.Serialise as Ser
import Control.Applicative
import Control.DeepSeq
import Control.Monad
import Data.Aeson
import Data.Aeson.TH
import Data.Binary (Binary)
@ -36,8 +41,10 @@ import Data.Fix
import Data.Functor.Classes
import Data.Hashable
import Data.Hashable.Lifted
import Data.List.NonEmpty (NonEmpty)
import Data.List (inits, tails)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Ord.Deriving
import Data.Text (Text, pack, unpack)
@ -45,6 +52,9 @@ import Data.Traversable
import GHC.Exts
import GHC.Generics
import Language.Haskell.TH.Syntax
import Lens.Family2
import Lens.Family2.Stock (_1)
import Lens.Family2.TH
import Nix.Atoms
import Nix.Parser.Library (SourcePos(..))
import Nix.Utils
@ -389,6 +399,47 @@ instance FromJSON NBinaryOp
instance FromJSON a => FromJSON (NExprF a)
instance FromJSON NExpr
$(makeTraversals ''NExprF)
$(makeTraversals ''Binding)
$(makeTraversals ''Params)
$(makeTraversals ''Antiquoted)
$(makeTraversals ''NString)
$(makeTraversals ''NKeyName)
$(makeTraversals ''NUnaryOp)
$(makeTraversals ''NBinaryOp)
-- $(makeLenses ''Fix)
class NExprAnn ann g | g -> ann where
fromNExpr :: g r -> (NExprF r, ann)
toNExpr :: (NExprF r, ann) -> g r
ekey :: NExprAnn ann g
=> NonEmpty Text
-> Lens' (Fix g) (Maybe (Fix g))
ekey keys f e@(Fix x) | (NSet xs, ann) <- fromNExpr x =
case go xs of
((v, []):_) -> fromMaybe e <$> f (Just v)
((v, r:rest):_) -> ekey (r :| rest) f v
_ -> f Nothing <&> \case
Nothing -> e
Just v ->
let entry = NamedVar (NE.map (StaticKey ?? Nothing) keys) v
in Fix (toNExpr (NSet (entry : xs), ann))
where
go xs = do
let keys' = NE.toList keys
(ks, rest) <- zip (inits keys') (tails keys')
case ks of
[] -> empty
j:js -> do
NamedVar ns v <- xs
guard $ (j:js) == (NE.toList ns ^.. traverse._StaticKey._1)
return (v, rest)
ekey _ f e = fromMaybe e <$> f Nothing
stripPositionInfo :: NExpr -> NExpr
stripPositionInfo = transport phi
where

4
src/Nix/Normal.hs
View file

@ -45,8 +45,8 @@ normalFormBy k n v = do
traceM $ replicate n ' ' ++ "normalFormBy: List[" ++ show i ++ "]"
t `k` normalFormBy k (succ n)
NVSet s p ->
fmap (Fix . flip NVSetF p) $ sequence $ flip M.mapWithKey s $ \key t -> do
traceM $ replicate n ' ' ++ "normalFormBy: Set{" ++ show key ++ "}"
fmap (Fix . flip NVSetF p) $ sequence $ flip M.mapWithKey s $ \ky t -> do
traceM $ replicate n ' ' ++ "normalFormBy: Set{" ++ show ky ++ "}"
t `k` normalFormBy k (succ n)
NVClosure p f -> return $ Fix $ NVClosureF p f
NVPath fp -> return $ Fix $ NVPathF fp

49
src/Nix/Pretty.hs
View file

@ -49,13 +49,21 @@ data NixDoc = NixDoc
-- operator. It is needed to determine if we need to wrap the expression in
-- parentheses.
, rootOp :: OperatorInfo
, wasPath :: Bool -- This is needed so that when a path is used in a selector path
-- we can add brackets appropiately
}
mkNixDoc :: Doc -> OperatorInfo -> NixDoc
mkNixDoc d o = NixDoc { withoutParens = d, rootOp = o, wasPath = False }
-- | 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 minBound NAssocNone "simple expr"
simpleExpr d = mkNixDoc d (OperatorInfo minBound NAssocNone "simple expr")
pathExpr :: Doc -> NixDoc
pathExpr d = (simpleExpr d) { wasPath = True }
-- | 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
@ -64,7 +72,7 @@ simpleExpr = flip NixDoc $ OperatorInfo minBound NAssocNone "simple expr"
-- binding).
leastPrecedence :: Doc -> NixDoc
leastPrecedence =
flip NixDoc $ OperatorInfo maxBound NAssocNone "least precedence"
flip mkNixDoc $ OperatorInfo maxBound NAssocNone "least precedence"
appOp :: OperatorInfo
appOp = getBinaryOperator NApp
@ -86,10 +94,17 @@ wrapParens op sub
&& associativity op /= NAssocNone = withoutParens sub
| otherwise = parens $ withoutParens sub
-- Used in the selector case to print a path in a selector as
-- "${./abc}"
wrapPath :: OperatorInfo -> NixDoc -> Doc
wrapPath op sub =
if wasPath sub then dquotes (text "$" <> braces (withoutParens sub))
else wrapParens op sub
prettyString :: NString NixDoc -> Doc
prettyString (DoubleQuoted parts) = dquotes . hcat . map prettyPart $ parts
where prettyPart (Plain t) = text . concatMap escape . unpack $ t
prettyPart EscapedNewline = text "\n"
prettyPart EscapedNewline = text "''\\n"
prettyPart (Antiquoted r) = text "$" <> braces (withoutParens r)
escape '"' = "\\\""
escape x = maybe [x] (('\\':) . (:[])) $ toEscapeCode x
@ -102,7 +117,7 @@ prettyString (Indented _ parts)
f xs = xs
prettyLine = hcat . map prettyPart
prettyPart (Plain t) = text . unpack . replace "${" "''${" . replace "''" "'''" $ t
prettyPart EscapedNewline = text "\n"
prettyPart EscapedNewline = text "\\n"
prettyPart (Antiquoted r) = text "$" <> braces (withoutParens r)
prettyParams :: Params NixDoc -> Doc
@ -152,7 +167,7 @@ prettyOriginExpr = withoutParens . go
go = exprFNixDoc . annotated . getCompose . fmap render
render Nothing = simpleExpr $ text "_"
render (Just (NValue (reverse -> p:_) _)) = go (originExpr p)
render (Just (NValue (reverse -> p:_) _)) = go (_originExpr p)
render (Just (NValue _ _)) = simpleExpr $ text "?"
-- simpleExpr $ foldr ((<$>) . parens . indent 2 . withoutParens
-- . go . originExpr)
@ -174,8 +189,8 @@ exprFNixDoc = \case
NAbs args body -> leastPrecedence $
nest 2 ((prettyParams args <> colon) <$> withoutParens body)
NBinary NApp fun arg ->
NixDoc (wrapParens appOp fun <+> wrapParens appOpNonAssoc arg) appOp
NBinary op r1 r2 -> flip NixDoc opInfo $ hsep
mkNixDoc (wrapParens appOp fun <+> wrapParens appOpNonAssoc arg) appOp
NBinary op r1 r2 -> flip mkNixDoc opInfo $ hsep
[ wrapParens (f NAssocLeft) r1
, text $ unpack $ operatorName opInfo
, wrapParens (f NAssocRight) r2
@ -185,16 +200,16 @@ exprFNixDoc = \case
f x | associativity opInfo /= x = opInfo { associativity = NAssocNone }
| otherwise = opInfo
NUnary op r1 ->
NixDoc (text (unpack (operatorName opInfo)) <> wrapParens opInfo r1) opInfo
mkNixDoc (text (unpack (operatorName opInfo)) <> wrapParens opInfo r1) opInfo
where opInfo = getUnaryOperator op
NSelect r attr o ->
(if isJust o then leastPrecedence else flip NixDoc selectOp) $
wrapParens selectOp r <> dot <> prettySelector attr <> ordoc
(if isJust o then leastPrecedence else flip mkNixDoc selectOp) $
wrapPath selectOp r <> dot <> prettySelector attr <> ordoc
where ordoc = maybe empty (((space <> text "or") <+>) . wrapParens selectOp) o
NHasAttr r attr ->
NixDoc (wrapParens hasAttrOp r <+> text "?" <+> prettySelector attr) hasAttrOp
mkNixDoc (wrapParens hasAttrOp r <+> text "?" <+> prettySelector attr) hasAttrOp
NEnvPath p -> simpleExpr $ text ("<" ++ p ++ ">")
NLiteralPath p -> simpleExpr $ text $ case p of
NLiteralPath p -> pathExpr $ text $ case p of
"./" -> "./."
"../" -> "../."
".." -> "../."
@ -249,7 +264,7 @@ printNix = cata phi
removeEffects :: Functor m => NValueF m (NThunk m) -> NValueNF m
removeEffects = Fix . fmap dethunk
where
dethunk (NThunk _ (Value v)) = removeEffects (baseValue v)
dethunk (NThunk _ (Value v)) = removeEffects (_baseValue v)
dethunk (NThunk _ _) = Fix $ NVStrF (NixString "<thunk>" mempty)
removeEffectsM :: MonadVar m => NValueF m (NThunk m) -> m (NValueNF m)
@ -267,18 +282,18 @@ prettyNValueProv = \case
NValue ps v -> do
v' <- prettyNValueF v
pure $ v' </> indent 2 (parens (mconcat
(text "from: " : map (prettyOriginExpr . originExpr) ps)))
(text "from: " : map (prettyOriginExpr . _originExpr) ps)))
prettyNThunk :: MonadVar m => NThunk m -> m Doc
prettyNThunk = \case
t@(NThunk ps _) -> do
v' <- fmap prettyNValueNF (dethunk t)
pure $ v' </> indent 2 (parens (mconcat
(text "thunk from: " : map (prettyOriginExpr . originExpr) ps)))
(text "thunk from: " : map (prettyOriginExpr . _originExpr) ps)))
dethunk :: MonadVar m => NThunk m -> m (NValueNF m)
dethunk = \case
NThunk _ (Value v) -> removeEffectsM (baseValue v)
NThunk _ (Value v) -> removeEffectsM (_baseValue v)
NThunk _ (Thunk _ active ref) -> do
nowActive <- atomicModifyVar active (True,)
if nowActive
@ -286,5 +301,5 @@ dethunk = \case
else do
eres <- readVar ref
case eres of
Computed v -> removeEffectsM (baseValue v)
Computed v -> removeEffectsM (_baseValue v)
_ -> pure $ Fix $ NVStrF (NixString "<thunk>" mempty)

5
src/Nix/Render/Frame.hs
View file

@ -98,6 +98,11 @@ renderEvalFrame level f = do
fmap (:[]) $ renderLocation ann
=<< renderExpr level "While forcing thunk from"
"Forcing thunk" e
Calling name ann ->
fmap (:[]) $ renderLocation ann $
text "While calling builtins." <> text name
_ -> pure []
renderExpr :: (MonadReader e m, Has e Options, MonadFile m)

1
src/Nix/Scope.hs
View file

@ -15,6 +15,7 @@ import Control.Monad.Reader
import qualified Data.HashMap.Lazy as M
import Data.Semigroup
import Data.Text (Text)
import Lens.Family2
import Nix.Utils
newtype Scope a = Scope { getScope :: AttrSet a }

25
src/Nix/Utils.hs
View file

@ -8,20 +8,20 @@
module Nix.Utils (module Nix.Utils, module X) where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Monad
import Control.Monad.Fix
import qualified Data.Aeson as A
import qualified Data.Aeson.Encoding as A
import Data.Fix
import Data.Functor.Identity
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.List (sortOn)
import Data.Monoid (Endo)
import Data.Text (Text)
import qualified Data.Vector as V
import Lens.Family2 as X
import Lens.Family2.Stock (_1, _2)
#if ENABLE_TRACING
import Debug.Trace as X
@ -46,10 +46,6 @@ type AlgM f m a = f a -> m a
-- | An "transform" here is a modification of a catamorphism.
type Transform f a = (Fix f -> a) -> Fix f -> a
infixr 0 &
(&) :: a -> (a -> c) -> c
(&) = flip ($)
(<&>) :: Functor f => f a -> (a -> c) -> f c
(<&>) = flip (<$>)
@ -91,28 +87,17 @@ 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
hasLens :: Lens' a b
instance Has a a where
hasLens f = f
instance Has (a, b) a where
hasLens f (x, y) = (, y) <$> f x
hasLens = _1
instance Has (a, b) b where
hasLens f (x, y) = (x,) <$> f y
hasLens = _2
toEncodingSorted :: A.Value -> A.Encoding
toEncodingSorted = \case

35
src/Nix/Value.hs
View file

@ -15,6 +15,7 @@
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
@ -30,13 +31,16 @@ import Control.Monad.Trans.Except
import qualified Data.Aeson as A
import Data.Align
import Data.Fix
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import qualified Data.HashSet as S
import Data.Hashable
import Data.Text (Text)
import Data.These
import Data.Typeable (Typeable)
import GHC.Generics
import Lens.Family2
import Lens.Family2.Stock
import Lens.Family2.TH
import Nix.Atoms
import Nix.Expr.Types
import Nix.Expr.Types.Annotated
@ -117,8 +121,8 @@ type NValueNF m = Fix (NValueF m) -- normal form
type ValueSet m = AttrSet (NThunk m)
data Provenance m = Provenance
{ lexicalScope :: Scopes m (NThunk m)
, originExpr :: NExprLocF (Maybe (NValue m))
{ _lexicalScope :: Scopes m (NThunk m)
, _originExpr :: NExprLocF (Maybe (NValue m))
-- ^ When calling the function x: x + 2 with argument x = 3, the
-- 'originExpr' for the resulting value will be 3 + 2, while the
-- 'contextExpr' will be @(x: x + 2) 3@, preserving not only the
@ -126,13 +130,13 @@ data Provenance m = Provenance
}
data NThunk m = NThunk
{ thunkProvenance :: [Provenance m]
, baseThunk :: Thunk m (NValue m)
{ _thunkProvenance :: [Provenance m]
, _baseThunk :: Thunk m (NValue m)
}
data NValue m = NValue
{ valueProvenance :: [Provenance m]
, baseValue :: NValueF m (NThunk m)
{ _valueProvenance :: [Provenance m]
, _baseValue :: NValueF m (NThunk m)
}
addProvenance :: (NValue m -> Provenance m) -> NValue m -> NValue m
@ -362,3 +366,20 @@ data ValueFrame m
deriving (Show, Typeable)
instance Typeable m => Exception (ValueFrame m)
$(makeTraversals ''NValueF)
$(makeLenses ''Provenance)
$(makeLenses ''NThunk)
$(makeLenses ''NValue)
alterF :: (Eq k, Hashable k, Functor f)
=> (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)
alterF f k m = f (M.lookup k m) <&> \case
Nothing -> M.delete k m
Just v -> M.insert k v m
hashAt :: VarName -> Lens' (AttrSet v) (Maybe v)
hashAt = flip alterF
key :: Applicative f => VarName -> LensLike' f (NValue m) (Maybe (NThunk m))
key k = baseValue._NVSetF._1.hashAt k

3
tests/Main.hs
View file

@ -25,6 +25,7 @@ import Nix.Value
import qualified NixLanguageTests
import qualified ParserTests
import qualified PrettyTests
import qualified PrettyParseTests
import System.Environment
import System.FilePath.Glob
import System.Posix.Files
@ -92,9 +93,11 @@ main = do
[ ParserTests.tests
, EvalTests.tests
, PrettyTests.tests
, PrettyParseTests.tests
, evalComparisonTests ] ++
[ testCase "Nix language tests present" ensureLangTestsPresent
| runLangTests ] ++
[ nixLanguageTests | runLangTests ] ++
[ testCase "Nixpkgs parses without errors" ensureNixpkgsCanParse
| runNixpkgsTests ]

165
tests/PrettyParseTests.hs Normal file
View file

@ -0,0 +1,165 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# OPTIONS -Wno-orphans#-}
module PrettyParseTests where
import Test.Tasty.QuickCheck hiding (Success, Failure)
import Test.Tasty
import Test.QuickCheck.Instances.Text ()
import Test.QuickCheck.Instances.Semigroup ()
import qualified Test.QuickCheck.Property as P
import Nix.Expr (NExpr, NExprF(..), NString(..), NUnaryOp(..), NBinaryOp(..)
, Params(..), NKeyName(..), Antiquoted(..), Binding(..))
import Nix.Atoms
import Nix.Pretty
import Nix.Parser
import Generic.Random
import Data.Fix
import Data.Text (Text, pack, unpack)
import Text.Megaparsec (Pos, SourcePos, mkPos)
import Control.Monad
import Data.Algorithm.Diff
import Data.Algorithm.DiffOutput
import Data.Char
-- Instead of using the Generic arbitrary instance (which doesn't exist
-- anyway for Text), we use a different generator which just prints
-- sensible looking variable names
custom :: GenList '[Text]
custom = asciiText :@ Nil
asciiString :: Gen String
asciiString = do
n <- choose (1, 15)
replicateM n (elements ['a'..'z'])
asciiText :: Gen Text
asciiText = pack <$> asciiString
pcustom :: GenList '[Pos]
pcustom = (arbitrary) :@ Nil
-- | This generator generates selects one of the constructors uniformly
-- and also decreases the size of the generator by dividing by the
-- branching factor. This ensures sensible termination.
genArb :: (GArbitrary (Options 'Sized '[Text]) a, GUniformWeight a) => Gen a
genArb = genericArbitraryWith (setGenerators custom sizedOpts) uniform
-- Might want to replace this instance with a constant value
instance Arbitrary Pos where
arbitrary = mkPos <$> (getSmall <$> arbitrary `suchThat` (> 0))
instance Arbitrary (f (Fix f)) => Arbitrary (Fix f) where
arbitrary = genArb
instance Arbitrary f => Arbitrary (NString f) where
arbitrary = genArb
instance Arbitrary SourcePos where
arbitrary = genericArbitraryWith (setGenerators pcustom sizedOpts) uniform
instance Arbitrary f => Arbitrary (Binding f) where
arbitrary = genArb
instance Arbitrary f => Arbitrary (NKeyName f) where
arbitrary = genArb
instance Arbitrary f => Arbitrary (Params f) where
arbitrary = genArb
instance Arbitrary NAtom where
arbitrary = genArb
instance Arbitrary NUnaryOp where
arbitrary = genArb
instance Arbitrary NBinaryOp where
arbitrary = genArb
instance (Arbitrary f) => Arbitrary (Antiquoted Text f) where
arbitrary = genArb
instance (Arbitrary f) => Arbitrary (Antiquoted (NString f) f) where
arbitrary = genArb
-- This is written by hand so we can use `fairList` rather than
-- the normal list Arbitrary instance which makes the generator
-- terminate. The distribution is not scientifically chosen.
instance Arbitrary f => Arbitrary (NExprF f) where
arbitrary =
sized $ \n ->
if n < 2
then oneof [nConstant, nStr, nSym, nLiteralPath, nEnvPath ]
else
frequency
[ (1, nConstant)
, (1, nSym)
, (4, resize (n `div` 3) nIf)
, (10, nRecSet )
, (20, nSet )
, (5, nList )
, (2, nUnary )
, (2, resize (n `div` 3) nBinary )
, (3, resize (n `div` 3) nSelect )
, (20, resize (n `div` 2) nAbs )
, (2, resize (n `div` 2) nHasAttr )
, (10, resize (n `div` 2) nLet )
, (10, resize (n `div` 2) nWith )
, (1, resize (n `div` 2) nAssert)
]
where
nConstant = NConstant <$> arbitrary
nStr = NStr <$> arbitrary
nSym = NSym <$> asciiText
nList = NList <$> fairList arbitrary
nSet = NSet <$> fairList arbitrary
nRecSet = NRecSet <$> fairList arbitrary
nLiteralPath = NLiteralPath <$> asciiString
nEnvPath = NEnvPath <$> asciiString
nUnary = NUnary <$> arbitrary <*> arbitrary
nBinary = NBinary <$> arbitrary <*> arbitrary <*> arbitrary
nSelect = NSelect <$> arbitrary <*> arbitrary <*> arbitrary
nHasAttr = NHasAttr <$> arbitrary <*> arbitrary
nAbs = NAbs <$> arbitrary <*> arbitrary
nLet = NLet <$> arbitrary <*> arbitrary
nIf = NIf <$> arbitrary <*> arbitrary <*> arbitrary
nWith = NWith <$> arbitrary <*> arbitrary
nAssert = NAssert <$> arbitrary <*> arbitrary
-- | Useful when there are recursive positions at each element of the list
-- as it divides the size by the length of the generated list.
fairList :: Gen a -> Gen [a]
fairList g = do
s <- getSize
k <- choose (0, s)
-- Use max here to avoid dividing by zero when there is the empty list
resize (s `div` (max 1 k)) $ vectorOf k g
-- | Test that pretty . parse . pretty == pretty
prop_prettyparse :: NExpr -> P.Result
prop_prettyparse p =
case parse (pretty p) of
Failure s -> P.rejected { P.reason = show s ++ show (pretty p) }
Success v ->
let pp = normalise (unpack (pretty p))
pv = normalise (unpack (pretty v))
in (P.liftBool (pp == pv)) { P.reason = "Bad parse:" ++ pp ++ pv ++ ppDiff (diff pp pv) ++ show p ++ show v}
where
pretty = pack . show . prettyNix
parse = parseNixText
normalise = unlines . map (reverse . dropWhile isSpace . reverse) . lines
diff :: String -> String -> [Diff [String]]
diff s1 s2 = getDiff (map (:[]) (lines s1)) (map (:[]) (lines s2))
tests :: TestTree
tests = testProperty "Pretty Parse Property" prop_prettyparse