diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,39 @@ # ChangeLog +## [(diff)](https://github.com/haskell-nix/hnix/compare/0.16.0...0.17.0#files_bucket) 0.17.0 + +* Additional + * `Nix.Effect` + * [(link)](https://github.com/haskell-nix/hnix/pull/1051) Introduction of new type NarContent, a tagged union type of `byteString` and `FilePath`. + * [(link)](https://github.com/haskell-nix/hnix/pull/1051) getURL of instance MonadHttp IO is finally working through hnix-store. Which also means + builtins.fetchurl is working through it. +* Breaking: + * `Nix.Effect` + * [(link)](https://github.com/haskell-nix/hnix/pull/1051) MonadStore's addToStore signature changed to `StorePathName -> NarContent -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath)` with new introduction of NarContent. Which enable us to add byteString as file to Store. It is corresponding to the hnix-store api change. + * `Nix.Expr.Types` + * [(link)](https://github.com/haskell-nix/hnix/pull/1042/files) The central HNix type `NExprF` changed, the `NApp` was moved out of `NBinary` & now a `NExprF` constructor of its own, the type signatures were changed accordingly. + * [(link)](https://github.com/haskell-nix/hnix/pull/1038/files) project was using `megaparsec` `{,Source}Pos` and to use it shipped a lot of orphan instances. To improve the situation & performance (reports [#1026](https://github.com/haskell-nix/hnix/issues/1026), [#746](https://github.com/haskell-nix/hnix/issues/746)) project uses `N{,Source}Pos` types, related type signatures were changed accordingly. + * `Nix.Value` + * [(link)](https://github.com/haskell-nix/hnix/pull/1046/files) Unify builder `mkNV*` and `NV*` patterns by bidirectional synonyms, a lot of builders `mkNV*` are removed, and merged to `NV*`. e.g. instead of builder `mkNVList`, `NVList` should be used. + * [(link)](https://github.com/haskell-nix/hnix/pull/1046/files) Constraint `NVConstraint f = (Comonad f, Applicative f)` was introduced, in order to unify builder `mkNV*` and `NV*` patterns. + + * `Nix.Parser`: + * [(link)](https://github.com/haskell-nix/hnix/pull/1047/files) rm `OperatorInfo`, using `NOperatorDef`. Number of functions changed signatures accordingly: + * In `Nix.Pretty`: + * `NixDoc ann` + * `mkNixDoc` + * `selectOp` + * `hasAttrOp` + * `precedenceWrap` + * `wrapPath` + * In `Nix.Parser`: + * rm `get{App,Unary,Binary,Special}Operator`, currely `NOp` class instances are used instead. + + * `Nix.Pretty`: + * [(link)](https://github.com/haskell-nix/hnix/pull/1047/files) rm `appOp`, instead use `appOpDef`. + * [(link)](https://github.com/haskell-nix/hnix/pull/1047/files) `precedenceWrap` behaviour is changed (to be literal to the name), the old behaviour is now a `wrap` function. + ## [(diff)](https://github.com/haskell-nix/hnix/compare/0.15.0...0.16.0#files_bucket) 0.16.0 On update problems, please reach out to us. For support refere to: https://github.com/haskell-nix/hnix/issues/984 diff --git a/hnix.cabal b/hnix.cabal --- a/hnix.cabal +++ b/hnix.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hnix -version: 0.16.0 +version: 0.17.0 synopsis: Haskell implementation of the Nix language description: Haskell implementation of the Nix language. category: System, Data, Nix @@ -327,7 +327,56 @@ manual: True default: False +common shared + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + , OverloadedStrings + , DeriveGeneric + , DeriveDataTypeable + , DeriveFunctor + , DeriveFoldable + , DeriveTraversable + , DeriveLift + , FlexibleContexts + , FlexibleInstances + , ScopedTypeVariables + , StandaloneDeriving + , TypeApplications + , TypeSynonymInstances + , InstanceSigs + , MultiParamTypeClasses + , TupleSections + , LambdaCase + , BangPatterns + , ViewPatterns + build-depends: + base >= 4.12 && < 5 + , data-fix >= 0.3.0 && < 0.4 + , exceptions >= 0.10.0 && < 0.11 + , filepath >= 1.4.2 && < 1.5 + , optparse-applicative >= 0.14.3 && < 0.19 + , relude >= 1.0.0 && < 1.3 + , serialise >= 0.2.1 && < 0.3 + , template-haskell >= 2.13 && < 2.22 + , time >= 1.8.0 && < 1.9 || >= 1.9.3 && < 1.13 + ghc-options: + -Wall + -Wno-incomplete-uni-patterns + -fprint-potential-instances + if flag(optimize) + default-extensions: + ApplicativeDo + ghc-options: + -O2 + -fexpose-all-unfoldings + -fspecialise-aggressively + -- if !flag(profiling) + -- build-depends: + -- ghc-datasize + library + import: shared exposed-modules: Nix Nix.Prelude @@ -386,107 +435,65 @@ Paths_hnix hs-source-dirs: src - ghc-options: - -Wall - -fprint-potential-instances build-depends: - aeson >= 1.4.2 && < 1.6 || >= 2.0 && < 2.1 + aeson >= 1.4.2 && < 1.6 || >= 2.0 && < 2.2 , array >= 0.4 && < 0.6 - , base >= 4.12 && < 4.16 , base16-bytestring >= 0.1.1 && < 1.1 , binary >= 0.8.5 && < 0.9 , bytestring >= 0.10.8 && < 0.12 , cryptonite , comonad >= 5.0.4 && < 5.1 , containers >= 0.5.11.0 && < 0.7 - , data-fix >= 0.3.0 && < 0.4 - , deepseq >= 1.4.3 && <1.5 + , deepseq >= 1.4.3 && <1.6 , deriving-compat >= 0.3 && < 0.7 , directory >= 1.3.1 && < 1.4 - , exceptions >= 0.10.0 && < 0.11 - , filepath >= 1.4.2 && < 1.5 + , extra >= 1.7 && < 1.8 , free >= 5.1 && < 5.2 , gitrev >= 1.1.0 && < 1.4 , hashable >= 1.2.5 && < 1.5 , hashing >= 0.1.0 && < 0.2 - , hnix-store-core >= 0.5.0 && < 0.6 - , hnix-store-remote >= 0.5.0 && < 0.6 + , hnix-store-core >= 0.6.0 && < 0.8 + , hnix-store-remote >= 0.6.0 && < 0.7 , http-client >= 0.5.14 && < 0.6 || >= 0.6.4 && < 0.8 , http-client-tls >= 0.3.5 && < 0.4 , http-types >= 0.12.2 && < 0.13 , lens-family >= 1.2.2 && < 2.2 , lens-family-core >= 1.2.2 && < 2.2 , lens-family-th >= 0.5.0 && < 0.6 - , logict >= 0.6.0 && < 0.7 || >= 0.7.0.2 && < 0.8 - , megaparsec >= 7.0 && < 9.3 + , logict >= 0.6.0 && < 0.7 || >= 0.7.0.2 && < 0.9 + , megaparsec >= 7.0 && < 9.6 , monad-control >= 1.0.2 && < 1.1 , monadlist >= 0.0.2 && < 0.1 - , mtl >= 2.2.2 && < 2.3 + , mtl >= 2.2.2 && < 2.4 , neat-interpolation >= 0.4 && < 0.6 - , optparse-applicative >= 0.14.3 && < 0.17 , parser-combinators >= 1.0.1 && < 1.4 , pretty-show >= 1.9.5 && < 1.11 , prettyprinter >= 1.7.0 && < 1.8 , process >= 1.6.3 && < 1.7 , ref-tf >= 0.5 && < 0.6 , regex-tdfa >= 1.2.3 && < 1.4 - , relude >= 1.0.0 && < 1.1.0 , scientific >= 0.3.6 && < 0.4 - , semialign >= 1.2 && < 1.3 - , serialise >= 0.2.1 && < 0.3 + , semialign >= 1.2 && < 1.4 , some >= 1.0.1 && < 1.1 , split >= 0.2.3 && < 0.3 , syb >= 0.7 && < 0.8 - , template-haskell >= 2.13 && < 2.18 -- provides: -- * compat instances for old versions of TH for old GHCs -- * orphan instances for TH missing instances -- aka Lift Text, Bytestring, Vector, Containers, -- we use Lift Text particulrarly for GHC 8.6 , th-lift-instances >= 0.1 && < 0.2 - , text >= 1.2.3 && < 1.3 - , these >= 1.0.1 && < 1.2 - , time >= 1.8.0 && < 1.9 || >= 1.9.3 && < 1.10 - , transformers >= 0.5.5 && < 0.6 + , text >= 1.2.3 && < 2.2 + , these >= 1.0.1 && < 1.3 + , transformers >= 0.5.5 && < 0.7 , transformers-base >= 0.4.5 && < 0.5 - , unix-compat >= 0.4.3 && < 0.6 - , unordered-containers >= 0.2.9 && < 0.3 - , vector >= 0.12.0 && < 0.13 + , unix-compat >= 0.4.3 && < 0.8 + , unordered-containers >= 0.2.14 && < 0.3 + , vector >= 0.12.0 && < 0.14 , xml >= 1.3.14 && < 1.4 - default-extensions: - NoImplicitPrelude - , OverloadedStrings - , DeriveGeneric - , DeriveDataTypeable - , DeriveFunctor - , DeriveFoldable - , DeriveTraversable - , DeriveLift - , FlexibleContexts - , FlexibleInstances - , ScopedTypeVariables - , StandaloneDeriving - , TypeApplications - , TypeSynonymInstances - , InstanceSigs - , MultiParamTypeClasses - , TupleSections - , LambdaCase - , BangPatterns - , ViewPatterns - if flag(optimize) - default-extensions: - ApplicativeDo - ghc-options: - -O2 - -fexpose-all-unfoldings - -fspecialise-aggressively - -- if !flag(profiling) - -- build-depends: - -- ghc-datasize - default-language: Haskell2010 executable hnix + import: shared hs-source-dirs: main main-is: Main.hs @@ -495,64 +502,25 @@ Paths_hnix autogen-modules: Paths_hnix - ghc-options: - -Wall build-depends: - aeson - , base + hnix + , aeson , comonad , containers - , data-fix , deepseq - , exceptions - , filepath , free , haskeline >= 0.8.0.0 && < 0.9 - , hnix - , optparse-applicative , pretty-show , prettyprinter , ref-tf - , relude , repline >= 0.4.0.0 && < 0.5 - , serialise - , template-haskell - , time - default-extensions: - NoImplicitPrelude - , OverloadedStrings - , DeriveGeneric - , DeriveDataTypeable - , DeriveFunctor - , DeriveFoldable - , DeriveTraversable - , DeriveLift - , FlexibleContexts - , FlexibleInstances - , ScopedTypeVariables - , StandaloneDeriving - , TypeApplications - , TypeSynonymInstances - , InstanceSigs - , MultiParamTypeClasses - , TupleSections - , LambdaCase - , BangPatterns - , ViewPatterns - if flag(optimize) - default-extensions: - ApplicativeDo - ghc-options: - -O2 - -fexpose-all-unfoldings - -fspecialise-aggressively if impl(ghc < 8.10) -- GHC < 8.10 comes with haskeline < 0.8, which we don't support. -- To simplify CI, we just disable the component. buildable: False - default-language: Haskell2010 test-suite hnix-tests + import: shared type: exitcode-stdio-1.0 main-is: Main.hs other-modules: @@ -565,113 +533,33 @@ TestCommon hs-source-dirs: tests - ghc-options: - -Wall - -threaded build-depends: - Diff + hnix + , Diff , Glob - , base , containers - , data-fix , directory - , exceptions - , filepath , hedgehog - , hnix , megaparsec , neat-interpolation - , optparse-applicative , pretty-show , prettyprinter , process - , relude , split , tasty , tasty-hedgehog , tasty-hunit , tasty-th - , serialise - , template-haskell - , time , unix-compat - default-extensions: - NoImplicitPrelude - , OverloadedStrings - , DeriveGeneric - , DeriveDataTypeable - , DeriveFunctor - , DeriveFoldable - , DeriveTraversable - , DeriveLift - , FlexibleContexts - , FlexibleInstances - , ScopedTypeVariables - , StandaloneDeriving - , TypeApplications - , TypeSynonymInstances - , InstanceSigs - , MultiParamTypeClasses - , TupleSections - , LambdaCase - , BangPatterns - , ViewPatterns - if flag(optimize) - default-extensions: - ApplicativeDo - ghc-options: - -O2 - -fexpose-all-unfoldings - -fspecialise-aggressively - default-language: Haskell2010 benchmark hnix-benchmarks + import: shared type: exitcode-stdio-1.0 main-is: Main.hs other-modules: ParserBench hs-source-dirs: benchmarks - ghc-options: - -Wall build-depends: - base + hnix , criterion - , data-fix - , exceptions - , filepath - , hnix - , optparse-applicative - , relude - , serialise - , template-haskell - , time - default-extensions: - NoImplicitPrelude - , OverloadedStrings - , DeriveGeneric - , DeriveDataTypeable - , DeriveFunctor - , DeriveFoldable - , DeriveTraversable - , DeriveLift - , FlexibleContexts - , FlexibleInstances - , ScopedTypeVariables - , StandaloneDeriving - , TypeApplications - , TypeSynonymInstances - , InstanceSigs - , MultiParamTypeClasses - , TupleSections - , LambdaCase - , BangPatterns - , ViewPatterns - if flag(optimize) - default-extensions: - ApplicativeDo - ghc-options: - -O2 - -fexpose-all-unfoldings - -fspecialise-aggressively - default-language: Haskell2010 diff --git a/main/Repl.hs b/main/Repl.hs --- a/main/Repl.hs +++ b/main/Repl.hs @@ -342,7 +342,7 @@ -- | @:set@ command setConfig :: (MonadNix e t f m, MonadIO m) => Text -> Repl e t f m () setConfig args = - list + handlePresence (liftIO $ Text.putStrLn "No option to set specified") (\ (x:_xs) -> case filter ((==x) . helpSetOptionName) helpSetOptions of @@ -393,7 +393,7 @@ listFiles word -- Attributes of sets in REPL context - | var : subFields <- Text.split (== '.') (fromString word) , not $ null subFields = + | var : subFields <- Text.split (== '.') (fromString word) , isPresent subFields = do state <- get maybe @@ -575,16 +575,19 @@ -> Repl e t f m () help hs _ = do liftIO $ putStrLn "Available commands:\n" - for_ hs $ \h -> - liftIO . - Text.putStrLn . - Prettyprinter.renderStrict . - Prettyprinter.layoutPretty Prettyprinter.defaultLayoutOptions $ - ":" - <> Prettyprinter.pretty (helpOptionName h) <> space - <> helpOptionSyntax h - <> Prettyprinter.line - <> Prettyprinter.indent 4 (helpOptionDoc h) + traverse_ + (\h -> + liftIO . + Text.putStrLn . + Prettyprinter.renderStrict . + Prettyprinter.layoutPretty Prettyprinter.defaultLayoutOptions $ + ":" + <> Prettyprinter.pretty (helpOptionName h) <> space + <> helpOptionSyntax h + <> Prettyprinter.line + <> Prettyprinter.indent 4 (helpOptionDoc h) + ) + hs options :: (MonadNix e t f m, MonadIO m) diff --git a/src/Nix.hs b/src/Nix.hs --- a/src/Nix.hs +++ b/src/Nix.hs @@ -114,7 +114,7 @@ f' <- demand f val <- case f' of - NVClosure _ g -> g $ mkNVSet mempty $ M.fromList args + NVClosure _ g -> g $ NVSet mempty $ M.fromList args _ -> pure f processResult handler val where @@ -142,7 +142,7 @@ where processKeys :: [VarName] -> NValue t f m -> m a processKeys kys v = - list + handlePresence (h v) (\ ((k : ks) :: [VarName]) -> do diff --git a/src/Nix/Builtins.hs b/src/Nix/Builtins.hs --- a/src/Nix/Builtins.hs +++ b/src/Nix/Builtins.hs @@ -7,6 +7,7 @@ {-# language MultiWayIf #-} {-# language PartialTypeSignatures #-} {-# language QuasiQuotes #-} +{-# language PatternSynonyms #-} {-# language TemplateHaskell #-} {-# language UndecidableInstances #-} {-# language PackageImports #-} -- 2021-07-05: Due to hashing Haskell IT system situation, in HNix we currently ended-up with 2 hash package dependencies @{hashing, cryptonite}@ @@ -23,7 +24,6 @@ import Nix.Prelude import GHC.Exception ( ErrorCall(ErrorCall) ) -import Control.Comonad ( Comonad ) import Control.Monad ( foldM ) import Control.Monad.Catch ( MonadCatch(catch) ) import Control.Monad.ListM ( sortByM ) @@ -126,14 +126,14 @@ ) => ToBuiltin t f m (a -> b) where toBuiltin name f = - pure $ mkNVBuiltin (coerce name) $ toBuiltin name . f <=< fromValue . Deeper + pure $ NVBuiltin (coerce name) $ toBuiltin name . f <=< fromValue . Deeper -- *** @WValue@ closure wrapper to have @Ord@ -- We wrap values solely to provide an Ord instance for genericClosure newtype WValue t f m = WValue (NValue t f m) -instance Comonad f => Eq (WValue t f m) where +instance NVConstraint f => Eq (WValue t f m) where WValue (NVConstant (NFloat x)) == WValue (NVConstant (NInt y)) = x == fromInteger y WValue (NVConstant (NInt x)) == WValue (NVConstant (NFloat y)) = @@ -145,7 +145,7 @@ ignoreContext x == ignoreContext y _ == _ = False -instance Comonad f => Ord (WValue t f m) where +instance NVConstraint f => Ord (WValue t f m) where WValue (NVConstant (NFloat x)) <= WValue (NVConstant (NInt y)) = x <= fromInteger y WValue (NVConstant (NInt x)) <= WValue (NVConstant (NFloat y)) = @@ -159,11 +159,8 @@ -- ** Helpers -mkNVBool - :: MonadNix e t f m - => Bool - -> NValue t f m -mkNVBool = mkNVConstant . NBool +pattern NVBool :: MonadNix e t f m => Bool -> NValue t f m +pattern NVBool a = NVConstant (NBool a) data NixPathEntryType = PathEntryPath @@ -307,7 +304,7 @@ -- list breakAfterFirstItem :: (a -> Bool) -> [a] -> ([a], [a]) breakAfterFirstItem f = - list + handlePresence mempty (\ (h : t) -> let (a, b) = break f t in (h : a, b)) (namePieces, versionPieces) = @@ -331,15 +328,15 @@ relStart = max 0 start - numDropped (before, rest) = B.splitAt relStart haystack caps :: NValue t f m - caps = mkNVList (f <$> captures) + caps = NVList (f <$> captures) f :: (ByteString, (Int, b)) -> NValue t f m f (a, (s, _)) = bool - nvNull + NVNull (thunkStr a) (s >= 0) -thunkStr :: Applicative f => ByteString -> NValue t f m +thunkStr :: NVConstraint f => ByteString -> NValue t f m thunkStr s = mkNVStrWithoutContext $ decodeUtf8 s hasKind @@ -360,7 +357,7 @@ let path = coerce . toString $ ignoreContext ns - unless (isAbsolute path) $ throwError $ ErrorCall $ "string " <> show path <> " doesn't represent an absolute path" + when (not (isAbsolute path)) $ throwError $ ErrorCall $ "string " <> show path <> " doesn't represent an absolute path" pure path NVPath path -> pure path @@ -422,16 +419,16 @@ nixPathNix :: forall e t f m . MonadNix e t f m => m (NValue t f m) nixPathNix = fmap - mkNVList + NVList $ foldNixPath mempty $ \p mn ty rest -> pure $ pure - (mkNVSet + (NVSet mempty (M.fromList [case ty of - PathEntryPath -> ("path", mkNVPath p) + PathEntryPath -> ("path", NVPath p) PathEntryURI -> ( "uri", mkNVStrWithoutContext $ fromString $ coerce p) , ( "prefix", mkNVStrWithoutContext $ maybeToMonoid mn) @@ -500,7 +497,7 @@ case (x, y) of (NVStr ns, NVSet apos _) -> maybe - (pure nvNull) + (pure NVNull) toValue (M.lookup @VarName (coerce $ ignoreContext ns) apos) _xy -> throwError $ ErrorCall $ "Invalid types for builtins.unsafeGetAttrPosNix: " <> show _xy @@ -613,7 +610,7 @@ tailNix = maybe (throwError $ ErrorCall "builtins.tail: empty list") - (pure . mkNVList) + (pure . NVList) . viaNonEmpty tail <=< fromValue @[NValue t f m] splitVersionNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) @@ -621,7 +618,7 @@ do version <- fromStringNoContext =<< fromValue v pure $ - mkNVList $ + NVList $ mkNVStrWithoutContext . show <$> splitVersion version @@ -642,7 +639,7 @@ EQ -> 0 GT -> 1 - pure $ mkNVConstant $ NInt cmpVers + pure $ NVConstant $ NInt cmpVers where mkText = fromStringNoContext <=< fromValue @@ -689,7 +686,7 @@ re = makeRegex p :: Regex mkMatch t = bool - (pure nvNull) + (pure NVNull) (toValue $ mkNixStringWithoutContext t) (not $ Text.null t) @@ -697,7 +694,7 @@ Just ("", sarr, "") -> do let submatches = fst <$> elems sarr - mkNVList <$> + NVList <$> traverse mkMatch (case submatches of @@ -705,7 +702,7 @@ [a] -> one a _:xs -> xs -- return only the matched groups, drop the full string ) - _ -> pure nvNull + _ -> pure NVNull splitNix :: forall e t f m @@ -726,7 +723,7 @@ regex = makeRegex p :: Regex haystack = encodeUtf8 s - pure $ mkNVList $ splitMatches 0 (elems <$> matchAllText regex haystack) haystack + pure $ NVList $ splitMatches 0 (elems <$> matchAllText regex haystack) haystack substringNix :: forall e t f m. MonadNix e t f m => Int -> Int -> NixString -> Prim m NixString substringNix start len str = @@ -825,7 +822,7 @@ n <- fromStringNoContext =<< fromValue attrName l <- fromValue @[NValue t f m] xs - mkNVList . catMaybes <$> + NVList . catMaybes <$> traverse (fmap (M.lookup @VarName $ coerce n) . fromValue <=< demand) l @@ -835,7 +832,7 @@ do ns <- coerceStringlikeToNixString DontCopyToStore x pure $ - mkNVStr $ + NVStr $ modifyNixContents (fromString . coerce takeFileName . toString) ns @@ -915,9 +912,9 @@ name <- toText <$> attrGetOr (takeFileName path) (fmap (coerce . toString) . fromStringNoContext) "name" attrs recursive <- attrGetOr True pure "recursive" attrs - Right (coerce . toText . coerce @StorePath @String -> s) <- addToStore name path recursive False + Right (coerce . toText . coerce @StorePath @String -> s) <- addToStore name (NarFile path) recursive False -- TODO: Ensure that s matches sha256 when not empty - pure $ mkNVStr $ mkNixStringWithSingletonContext (StringContext DirectPath s) s + pure $ NVStr $ mkNixStringWithSingletonContext (StringContext DirectPath s) s where coerceToPath = coerceToString callFunc DontCopyToStore CoerceAny @@ -927,8 +924,8 @@ dir <- demand nvdir case dir of - NVStr ns -> pure $ mkNVStr $ modifyNixContents (fromString . coerce takeDirectory . toString) ns - NVPath path -> pure $ mkNVPath $ takeDirectory path + NVStr ns -> pure $ NVStr $ modifyNixContents (fromString . coerce takeDirectory . toString) ns + NVPath path -> pure $ NVPath $ takeDirectory path v -> throwError $ ErrorCall $ "dirOf: expected string or path, got " <> show v -- jww (2018-04-28): This should only be a string argument, and not coerced? @@ -963,7 +960,7 @@ where anyMNix :: Monad m => (a -> m Bool) -> [a] -> m Bool anyMNix p = - list + handlePresence (pure False) (\ (x : xss) -> bool @@ -1028,7 +1025,7 @@ bool (do checkComparable k $ - list + handlePresence k (\ (WValue j:_) -> j) (S.toList ks) @@ -1158,7 +1155,7 @@ (s1, p1) <- fromValue @(AttrSet (NValue t f m), PositionSet) set1 (s2, p2) <- fromValue @(AttrSet (NValue t f m), PositionSet) set2 - pure $ mkNVSet (p2 `M.intersection` p1) (s2 `M.intersection` s1) + pure $ NVSet (p2 `M.intersection` p1) (s2 `M.intersection` s1) functionArgsNix :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) @@ -1167,7 +1164,7 @@ fun <- demand nvfun case fun of NVClosure p _ -> - toValue @(AttrSet (NValue t f m)) $ mkNVBool <$> + toValue @(AttrSet (NValue t f m)) $ NVBool <$> case p of Param name -> one (name, False) ParamSet _ _ pset -> isJust <$> M.fromList pset @@ -1272,7 +1269,7 @@ -- importNix :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -importNix = scopedImportNix $ mkNVSet mempty mempty +importNix = scopedImportNix $ NVSet mempty mempty -- | @scopedImport scope path@ -- An undocumented secret powerful function. @@ -1383,7 +1380,7 @@ let badType = throwError $ ErrorCall $ "builtins.lessThan: expected two numbers or two strings, got '" <> show va <> "' and '" <> show vb <> "'." - mkNVBool <$> + NVBool <$> case (va, vb) of (NVConstant ca, NVConstant cb) -> case (ca, cb) of @@ -1433,7 +1430,7 @@ do l <- fromValue @[NValue t f m] lst fmap - (mkNVSet mempty . M.fromList . reverse) + (NVSet mempty . M.fromList . reverse) (traverse (\ nvattrset -> do @@ -1500,8 +1497,8 @@ list <- demand nvlist fun <- demand nvfun (f, l) <- extractP (fun, list) - mkNVSet mempty - . fmap (mkNVList . reverse) + NVSet mempty + . fmap (NVList . reverse) . M.fromListWith (<>) <$> traverse (app f) l where @@ -1565,7 +1562,7 @@ do mres <- findPath @t @f @m x $ coerce $ toString $ ignoreContext ns - pure $ mkNVPath mres + pure $ NVPath mres (NVList _, _y ) -> throwError $ ErrorCall $ "expected a string, got " <> show _y (_x , NVStr _) -> throwError $ ErrorCall $ "expected a list, got " <> show _x @@ -1620,32 +1617,32 @@ \case A.Object m -> traverseToNValue - (mkNVSet mempty) + (NVSet mempty) #if MIN_VERSION_aeson(2,0,0) (M.mapKeys (coerce . AKM.toText) $ AKM.toHashMap m) #else (M.mapKeys coerce m) #endif - A.Array l -> traverseToNValue mkNVList (V.toList l) + A.Array l -> traverseToNValue NVList (V.toList l) A.String s -> pure $ mkNVStrWithoutContext s A.Number n -> pure $ - mkNVConstant $ + NVConstant $ either NFloat NInt (floatingOrInteger n) - A.Bool b -> pure $ mkNVBool b - A.Null -> pure nvNull + A.Bool b -> pure $ NVBool b + A.Null -> pure NVNull where traverseToNValue :: Traversable t0 => (t0 (NValue t f m) -> b) -> t0 A.Value -> m b traverseToNValue f v = f <$> traverse jsonToNValue v toJSONNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -toJSONNix = (fmap mkNVStr . toJSONNixString) <=< demand +toJSONNix = (fmap NVStr . toJSONNixString) <=< demand toXMLNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) -toXMLNix = (fmap (mkNVStr . toXML) . normalForm) <=< demand +toXMLNix = (fmap (NVStr . toXML) . normalForm) <=< demand typeOfNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) typeOfNix nvv = @@ -1677,19 +1674,19 @@ (onSuccess <$> demand e) where onSuccess v = - mkNVSet + NVSet mempty $ M.fromList - [ ("success", mkNVBool True) + [ ("success", NVBool True) , ("value" , v ) ] onError :: SomeException -> NValue t f m onError _ = - mkNVSet + NVSet mempty $ M.fromList - $ (, mkNVBool False) <$> + $ (, NVBool False) <$> [ "success" , "value" ] @@ -1717,40 +1714,37 @@ execNix :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) execNix xs = - do - xs' <- traverse (coerceStringlikeToNixString DontCopyToStore) =<< fromValue @[NValue t f m] xs - -- 2018-11-19: NOTE: Still need to do something with the context here - -- See prim_exec in nix/src/libexpr/primops.cc - -- Requires the implementation of EvalState::realiseContext - exec $ ignoreContext <$> xs' + -- 2018-11-19: NOTE: Still need to do something with the context here + -- See prim_exec in nix/src/libexpr/primops.cc + -- Requires the implementation of EvalState::realiseContext + (exec . fmap ignoreContext) =<< traverse (coerceStringlikeToNixString DontCopyToStore) =<< fromValue @[NValue t f m] xs fetchurlNix :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) fetchurlNix = (\case - NVSet _ s -> go (M.lookup "sha256" s) =<< demand =<< attrsetGet "url" s - v@NVStr{} -> go Nothing v + NVSet _ s -> fetch (M.lookup "sha256" s) =<< demand =<< attrsetGet "url" s + v@NVStr{} -> fetch Nothing v v -> throwError $ ErrorCall $ "builtins.fetchurl: Expected URI or set, got " <> show v ) <=< demand where - go :: Maybe (NValue t f m) -> NValue t f m -> m (NValue t f m) - go _msha = + -- 2022-01-21: NOTE: Needs to check the hash match. + fetch :: Maybe (NValue t f m) -> NValue t f m -> m (NValue t f m) + fetch _msha = \case NVStr ns -> either -- msha throwError toValue - =<< getURL =<< noContextAttrs ns + =<< getURL + =<< maybe + (throwError $ ErrorCall "builtins.fetchurl: unsupported arguments to url") + pure + (getStringNoContext ns) v -> throwError $ ErrorCall $ "builtins.fetchurl: Expected URI or string, got " <> show v - noContextAttrs ns = - maybe - (throwError $ ErrorCall "builtins.fetchurl: unsupported arguments to url") - pure - (getStringNoContext ns) - partitionNix :: forall e t f m . MonadNix e t f m @@ -1759,14 +1753,13 @@ -> m (NValue t f m) partitionNix f nvlst = do - l <- fromValue @[NValue t f m] nvlst let match t = (, t) <$> (fromValue =<< callFunc f t) - selection <- traverse match l + selection <- traverse match =<< fromValue @[NValue t f m] nvlst let (right, wrong) = partition fst selection - makeSide = mkNVList . fmap snd + makeSide = NVList . fmap snd toValue @(AttrSet (NValue t f m)) $ M.fromList @@ -1791,15 +1784,15 @@ derivationStrictNix :: MonadNix e t f m => NValue t f m -> m (NValue t f m) derivationStrictNix = derivationStrict -getRecursiveSizeNix :: (MonadIntrospect m, Applicative f) => a -> m (NValue t f m) -getRecursiveSizeNix = fmap (mkNVConstant . NInt . fromIntegral) . recursiveSize +getRecursiveSizeNix :: (MonadIntrospect m, NVConstraint f) => a -> m (NValue t f m) +getRecursiveSizeNix = fmap (NVConstant . NInt . fromIntegral) . recursiveSize getContextNix :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) getContextNix = \case (NVStr ns) -> - mkNVSet mempty <$> traverseToValue (getNixLikeContext $ toNixLikeContext $ getStringContext ns) + NVSet mempty <$> traverseToValue (getNixLikeContext $ toNixLikeContext $ getStringContext ns) x -> throwError $ ErrorCall $ "Invalid type for builtins.getContext: " <> show x <=< demand @@ -1927,7 +1920,7 @@ , add2 Normal "elem" elemNix , add2 Normal "elemAt" elemAtNix , add Normal "exec" execNix - , add0 Normal "false" (pure $ mkNVBool False) + , add0 Normal "false" (pure $ NVBool False) --, add Normal "fetchGit" fetchGit --, add Normal "fetchMercurial" fetchMercurial , add Normal "fetchTarball" fetchTarball @@ -1966,7 +1959,7 @@ , add2 Normal "match" matchNix , add2 Normal "mul" mulNix , add0 Normal "nixPath" nixPathNix - , add0 Normal "null" (pure nvNull) + , add0 Normal "null" (pure NVNull) , add Normal "parseDrvName" parseDrvNameNix , add2 Normal "partition" partitionNix , add Normal "path" pathNix @@ -1986,9 +1979,9 @@ , add Normal "tail" tailNix , add2 Normal "toFile" toFileNix , add Normal "toJSON" toJSONNix - , add Normal "toPath" toPathNix + , add Normal "toPath" toPathNix -- Deprecated in Nix: https://github.com/NixOS/nix/pull/2524 , add Normal "toXML" toXMLNix - , add0 Normal "true" (pure $ mkNVBool True) + , add0 Normal "true" (pure $ NVBool True) , add Normal "tryEval" tryEvalNix , add Normal "typeOf" typeOfNix , add Normal "unsafeDiscardOutputDependency" unsafeDiscardOutputDependencyNix @@ -2088,7 +2081,7 @@ opts <- askOptions pushScope - (one ("__includes", mkNVList $ mkNVStrWithoutContext . fromString . coerce <$> getInclude opts)) + (one ("__includes", NVList $ mkNVStrWithoutContext . fromString . coerce <$> getInclude opts)) (pushScopes base $ maybe @@ -2096,7 +2089,7 @@ (\ path act -> do traceM $ "Setting __cur_file = " <> show path - pushScope (one ("__cur_file", mkNVPath path)) act + pushScope (one ("__cur_file", NVPath path)) act ) mpath action @@ -2110,7 +2103,7 @@ => m (Scopes m (NValue t f m)) builtins = do - ref <- defer $ mkNVSet mempty <$> buildMap + ref <- defer $ NVSet mempty <$> buildMap (`pushScope` askScopes) . coerce . M.fromList . (one ("builtins", ref) <>) =<< topLevelBuiltins where buildMap :: m (HashMap VarName (NValue t f m)) diff --git a/src/Nix/Cited/Basic.hs b/src/Nix/Cited/Basic.hs --- a/src/Nix/Cited/Basic.hs +++ b/src/Nix/Cited/Basic.hs @@ -179,7 +179,7 @@ -> m a -> m a displayProvenance = - list + handlePresence id (\ (Provenance scope e@(AnnF s _) : _) -> withFrame Info $ ForcingExpr scope $ wrapExprLoc s e diff --git a/src/Nix/Convert.hs b/src/Nix/Convert.hs --- a/src/Nix/Convert.hs +++ b/src/Nix/Convert.hs @@ -21,7 +21,6 @@ import Nix.Atoms import Nix.Effects import Nix.Expr.Types -import Nix.Expr.Types.Annotated import Nix.Frames import Nix.String import Nix.Value @@ -371,85 +370,85 @@ instance Convertible e t f m => ToValue () m (NValue' t f m (NValue t f m)) where - toValue = const $ pure nvNull' + toValue = const $ pure NVNull' instance Convertible e t f m => ToValue Bool m (NValue' t f m (NValue t f m)) where - toValue = pure . mkNVConstant' . NBool + toValue = pure . NVConstant' . NBool instance Convertible e t f m => ToValue Int m (NValue' t f m (NValue t f m)) where - toValue = pure . mkNVConstant' . NInt . toInteger + toValue = pure . NVConstant' . NInt . toInteger instance Convertible e t f m => ToValue Integer m (NValue' t f m (NValue t f m)) where - toValue = pure . mkNVConstant' . NInt + toValue = pure . NVConstant' . NInt instance Convertible e t f m => ToValue Float m (NValue' t f m (NValue t f m)) where - toValue = pure . mkNVConstant' . NFloat + toValue = pure . NVConstant' . NFloat instance Convertible e t f m => ToValue NixString m (NValue' t f m (NValue t f m)) where - toValue = pure . mkNVStr' + toValue = pure . NVStr' instance Convertible e t f m => ToValue ByteString m (NValue' t f m (NValue t f m)) where - toValue = pure . mkNVStr' . mkNixStringWithoutContext . decodeUtf8 + toValue = pure . NVStr' . mkNixStringWithoutContext . decodeUtf8 instance Convertible e t f m => ToValue Text m (NValue' t f m (NValue t f m)) where - toValue = pure . mkNVStr' . mkNixStringWithoutContext + toValue = pure . NVStr' . mkNixStringWithoutContext instance Convertible e t f m => ToValue Path m (NValue' t f m (NValue t f m)) where - toValue = pure . mkNVPath' . coerce + toValue = pure . NVPath' instance Convertible e t f m => ToValue StorePath m (NValue' t f m (NValue t f m)) where toValue = toValue @Path . coerce instance Convertible e t f m - => ToValue SourcePos m (NValue' t f m (NValue t f m)) where - toValue (SourcePos f l c) = do - f' <- toValue $ mkNixStringWithoutContext $ fromString f - l' <- toValue $ unPos l - c' <- toValue $ unPos c + => ToValue NSourcePos m (NValue' t f m (NValue t f m)) where + toValue (NSourcePos f l c) = do + f' <- toValue $ mkNixStringWithoutContext $ fromString $ coerce f + l' <- toValue $ unPos $ coerce l + c' <- toValue $ unPos $ coerce c let pos = M.fromList [("file" :: VarName, f'), ("line", l'), ("column", c')] - pure $ mkNVSet' mempty pos + pure $ NVSet' mempty pos -- | With 'ToValue', we can always act recursively instance Convertible e t f m => ToValue [NValue t f m] m (NValue' t f m (NValue t f m)) where - toValue = pure . mkNVList' + toValue = pure . NVList' instance (Convertible e t f m , ToValue a m (NValue t f m) ) => ToValue [a] m (Deeper (NValue' t f m (NValue t f m))) where - toValue l = Deeper . mkNVList' <$> traverseToValue l + toValue l = Deeper . NVList' <$> traverseToValue l instance Convertible e t f m => ToValue (AttrSet (NValue t f m)) m (NValue' t f m (NValue t f m)) where - toValue s = pure $ mkNVSet' mempty s + toValue s = pure $ NVSet' mempty s instance (Convertible e t f m, ToValue a m (NValue t f m)) => ToValue (AttrSet a) m (Deeper (NValue' t f m (NValue t f m))) where toValue s = - liftA2 (\ v s -> Deeper $ mkNVSet' s v) + liftA2 (\ v s -> Deeper $ NVSet' s v) (traverseToValue s) stub instance Convertible e t f m => ToValue (AttrSet (NValue t f m), PositionSet) m (NValue' t f m (NValue t f m)) where - toValue (s, p) = pure $ mkNVSet' p s + toValue (s, p) = pure $ NVSet' p s instance (Convertible e t f m, ToValue a m (NValue t f m)) => ToValue (AttrSet a, PositionSet) m (Deeper (NValue' t f m (NValue t f m))) where toValue (s, p) = - liftA2 (\ v s -> Deeper $ mkNVSet' s v) + liftA2 (\ v s -> Deeper $ NVSet' s v) (traverseToValue s) (pure p) @@ -469,11 +468,11 @@ outputs = mkNixStringWithoutContext <$> nlcvOutputs nlcv ts :: [NValue t f m] <- traverseToValue outputs - list + handlePresence (pure Nothing) (fmap pure . toValue) ts - pure $ mkNVSet' mempty $ M.fromList $ catMaybes + pure $ NVSet' mempty $ M.fromList $ catMaybes [ ("path" ,) <$> path , ("allOutputs",) <$> allOutputs , ("outputs" ,) <$> outputs diff --git a/src/Nix/Effects.hs b/src/Nix/Effects.hs --- a/src/Nix/Effects.hs +++ b/src/Nix/Effects.hs @@ -6,6 +6,7 @@ {-# language GeneralizedNewtypeDeriving #-} {-# language UndecidableInstances #-} {-# language PackageImports #-} -- 2021-07-05: Due to hashing Haskell IT system situation, in HNix we currently ended-up with 2 hash package dependencies @{hashing, cryptonite}@ +{-# language TypeOperators #-} {-# options_ghc -Wno-orphans #-} @@ -36,6 +37,7 @@ import qualified System.Nix.Store.Remote as Store.Remote import qualified System.Nix.StorePath as Store +import qualified System.Nix.Nar as Store.Nar -- | A path into the nix store newtype StorePath = StorePath Path @@ -286,29 +288,39 @@ default getURL :: (MonadTrans t, MonadHttp m', m ~ t m') => Text -> m (Either ErrorCall StorePath) getURL = lift . getURL +baseNameOf :: Text -> Text +baseNameOf a = Text.takeWhileEnd (/='/') $ Text.dropWhileEnd (=='/') a +-- conversion from Store.StorePath to Effects.StorePath, different type with the same name. +toStorePath :: Store.StorePath -> StorePath +toStorePath = StorePath . coerce . decodeUtf8 @FilePath @ByteString . Store.storePathToRawFilePath + -- ** Instances instance MonadHttp IO where - getURL url = do - let urlstr = toString url - traceM $ "fetching HTTP URL: " <> urlstr - req <- parseRequest urlstr - manager <- - if secure req - then newTlsManager - else newManager defaultManagerSettings - -- print req - response <- httpLbs (req { method = "GET" }) manager - let status = statusCode $ responseStatus response - pure $ Left $ ErrorCall $ if status /= 200 - then - "fail, got " <> show status <> " when fetching url:" <> urlstr - else - -- do - -- let bstr = responseBody response - "success in downloading but hnix-store is not yet ready; url = " <> urlstr + getURL url = + do + let urlstr = toString url + traceM $ "fetching HTTP URL: " <> urlstr + req <- parseRequest urlstr + manager <- + bool + (newManager defaultManagerSettings) + newTlsManager + (secure req) + response <- httpLbs (req { method = "GET" }) manager + let status = statusCode $ responseStatus response + let body = responseBody response + -- let digest::Hash.Digest Hash.SHA256 = Hash.hash $ (B.concat . BL.toChunks) body + let name = baseNameOf url + bool + (pure $ Left $ ErrorCall $ "fail, got " <> show status <> " when fetching url = " <> urlstr) + -- using addTextToStore' result in different hash from the addToStore. + -- see https://github.com/haskell-nix/hnix/pull/1051#issuecomment-1031380804 + (addToStore name (NarText $ toStrict body) False False) + (status == 200) + deriving instance MonadHttp (t (Fix1 t)) @@ -368,17 +380,24 @@ type PathFilter m = Path -> m Bool type StorePathSet = HS.HashSet StorePath + -- ** @class MonadStore m@ +data NarContent = NarFile Path | NarText ByteString +-- | convert NarContent to NarSource needed in the store API +toNarSource :: MonadIO m => NarContent -> Store.Nar.NarSource m +toNarSource (NarFile path) = Store.Nar.dumpPath $ coerce path +toNarSource (NarText text) = Store.Nar.dumpString text + class Monad m => MonadStore m where - -- | Copy the contents of a local path to the store. The resulting store + -- | Copy the contents of a local path(Or pure text) to the store. The resulting store -- path is returned. Note: This does not support yet support the expected -- `filter` function that allows excluding some files. - addToStore :: StorePathName -> Path -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath) - default addToStore :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> Path -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath) + addToStore :: StorePathName -> NarContent -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath) + default addToStore :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> NarContent -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath) addToStore a b c d = lift $ addToStore a b c d -- | Like addToStore, but the contents written to the output path is a @@ -392,16 +411,15 @@ instance MonadStore IO where - addToStore name path recursive repair = + addToStore name content recursive repair = either (\ err -> pure $ Left $ ErrorCall $ "String '" <> show name <> "' is not a valid path name: " <> err) (\ pathName -> do - -- TODO: redesign the filter parameter - res <- Store.Remote.runStore $ Store.Remote.addToStore @Hash.SHA256 pathName (coerce path) recursive (const False) repair + res <- Store.Remote.runStore $ Store.Remote.addToStore @Hash.SHA256 pathName (toNarSource content) recursive repair either Left -- err - (pure . StorePath . coerce . decodeUtf8 @FilePath @ByteString . Store.storePathToRawFilePath) -- store path + (pure . toStorePath) -- store path <$> parseStoreResult "addToStore" res ) (Store.makeStorePathName name) @@ -411,20 +429,19 @@ res <- Store.Remote.runStore $ Store.Remote.addTextToStore name text references repair either Left -- err - (pure . StorePath . coerce . decodeUtf8 @FilePath @ByteString . Store.storePathToRawFilePath) -- path + (pure . toStorePath) -- path <$> parseStoreResult "addTextToStore" res -- ** Functions parseStoreResult :: Monad m => Text -> (Either String a, [Store.Remote.Logger]) -> m (Either ErrorCall a) -parseStoreResult name res = - pure $ either - (\ msg -> Left $ ErrorCall $ "Failed to execute '" <> toString name <> "': " <> msg <> "\n" <> show logs) - pure -- result - (fst res) - where - logs = snd res +parseStoreResult name (res, logs) = + pure $ + either + (\ msg -> Left $ ErrorCall $ "Failed to execute '" <> toString name <> "': " <> msg <> "\n" <> show logs) + pure + res addTextToStore :: (Framed e m, MonadStore m) => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m StorePath addTextToStore a b c d = @@ -440,7 +457,7 @@ either throwError pure - =<< addToStore (fromString $ coerce takeFileName p) p True False + =<< addToStore (fromString $ coerce takeFileName p) (NarFile p) True False toFile_ :: (Framed e m, MonadStore m) => Path -> Text -> m StorePath toFile_ p contents = addTextToStore (fromString $ coerce p) contents mempty False diff --git a/src/Nix/Effects/Derivation.hs b/src/Nix/Effects/Derivation.hs --- a/src/Nix/Effects/Derivation.hs +++ b/src/Nix/Effects/Derivation.hs @@ -292,10 +292,10 @@ (\out (coerce -> path) -> mkNixStringWithSingletonContext (StringContext (DerivationOutput out) drvPath) path) (outputs drv') drvPathWithContext = mkNixStringWithSingletonContext (StringContext AllOutputs drvPath) drvPath - attrSet = mkNVStr <$> M.fromList (("drvPath", drvPathWithContext) : Map.toList outputsWithContext) + attrSet = NVStr <$> M.fromList (("drvPath", drvPathWithContext) : Map.toList outputsWithContext) -- TODO: Add location information for all the entries. -- here --v - pure $ mkNVSet mempty $ M.mapKeys coerce attrSet + pure $ NVSet mempty $ M.mapKeys coerce attrSet where @@ -368,7 +368,7 @@ env <- if useJson then do - jsonString :: NixString <- lift $ toJSONNixString $ mkNVSet mempty $ M.mapKeys coerce $ + jsonString :: NixString <- lift $ toJSONNixString $ NVSet mempty $ M.mapKeys coerce $ deleteKeys [ "args", "__ignoreNulls", "__structuredAttrs" ] attrs rawString :: Text <- extractNixString jsonString pure $ one ("__json", rawString) diff --git a/src/Nix/Eval.hs b/src/Nix/Eval.hs --- a/src/Nix/Eval.hs +++ b/src/Nix/Eval.hs @@ -119,7 +119,7 @@ eval (NEnvPath p ) = evalEnvPath p eval (NUnary op arg ) = evalUnary op =<< arg -eval (NBinary NApp fun arg) = +eval (NApp fun arg ) = do f <- fun scope <- askScopes @@ -213,7 +213,7 @@ :: forall v m . MonadNixEval v m => [VarName] - -> SourcePos + -> NSourcePos -> AttrSet (m v) -> PositionSet -> m v @@ -241,7 +241,7 @@ ) ((`M.lookup` m) k) ) - (not $ null ks) + (isPresent ks) where insertVal :: m v -> (PositionSet, AttrSet (m v)) insertVal v = @@ -267,7 +267,7 @@ collect :: Binding r -> State - (AttrSet (SourcePos, [Binding r])) + (AttrSet (NSourcePos, [Binding r])) (Either VarName (Binding r)) collect (NamedVar (StaticKey x :| y : ys) val oldPosition) = do @@ -275,24 +275,24 @@ pure $ Left x where updateBindingInformation - :: AttrSet (SourcePos, [Binding r]) - -> AttrSet (SourcePos, [Binding r]) + :: AttrSet (NSourcePos, [Binding r]) + -> AttrSet (NSourcePos, [Binding r]) updateBindingInformation = M.insert x =<< maybe (mkBindingSingleton oldPosition) (\ (foundPosition, newBindings) -> second (<> newBindings) $ mkBindingSingleton foundPosition) . M.lookup x - mkBindingSingleton :: SourcePos -> (SourcePos, [Binding r]) + mkBindingSingleton :: NSourcePos -> (NSourcePos, [Binding r]) mkBindingSingleton np = (np , one $ bindValAt np) where - bindValAt :: SourcePos -> Binding r + bindValAt :: NSourcePos -> Binding r bindValAt = NamedVar (y :| ys) val collect x = pure $ pure x findBinding :: Either VarName (Binding r) - -> State (AttrSet (SourcePos, [Binding r])) (Binding r) + -> State (AttrSet (NSourcePos, [Binding r])) (Binding r) findBinding = either (\ x -> @@ -320,7 +320,7 @@ where buildResult :: Scopes m v - -> [([VarName], SourcePos, m v)] + -> [([VarName], NSourcePos, m v)] -> m (AttrSet v, PositionSet) buildResult scopes bindings = do @@ -335,13 +335,14 @@ pure (coerce res, p) where + insert :: (AttrSet (m v), PositionSet) -> ([VarName], NSourcePos, m v) -> m (AttrSet (m v), PositionSet) insert (m, p) (path, pos, value) = attrSetAlter path pos m p value mkThunk = defer . withScopes scopes encapsulate f attrs = mkThunk $ pushScope attrs f - applyBindToAdt :: Scopes m v -> Binding (m v) -> m [([VarName], SourcePos, m v)] + applyBindToAdt :: Scopes m v -> Binding (m v) -> m [([VarName], NSourcePos, m v)] applyBindToAdt _ (NamedVar (StaticKey "__overrides" :| []) finalValue pos) = do (o', p') <- fromValue =<< finalValue @@ -363,13 +364,13 @@ ) <$> processAttrSetKeys pathExpr where - processAttrSetKeys :: NAttrPath (m v) -> m ([VarName], SourcePos, m v) + processAttrSetKeys :: NAttrPath (m v) -> m ([VarName], NSourcePos, m v) processAttrSetKeys (h :| t) = maybe -- Empty attrset - return a stub. (pure (mempty, nullPos, toValue @(AttrSet v, PositionSet) mempty) ) (\ k -> - list + handlePresence -- No more keys in the attrset - return the result (pure ( one k, pos, finalValue ) ) -- There are unprocessed keys in attrset - recurse appending the results @@ -387,7 +388,7 @@ where processScope :: VarName - -> ([VarName], SourcePos, m v) + -> ([VarName], NSourcePos, m v) processScope var = ( one var , pos @@ -431,7 +432,7 @@ left (maybe left - (list + (handlePresence (pure . pure) (\ (y : ys) -> (extract (y :| ys) =<<)) ks diff --git a/src/Nix/Exec.hs b/src/Nix/Exec.hs --- a/src/Nix/Exec.hs +++ b/src/Nix/Exec.hs @@ -61,7 +61,7 @@ -> NAtom -> NValue t f m mkNVConstantWithProvenance scopes span x = - addProvenance (Provenance scopes . NConstantAnnF span $ x) $ mkNVConstant x + addProvenance (Provenance scopes . NConstantAnnF span $ x) $ NVConstant x mkNVStrWithProvenance :: MonadCited t f m @@ -70,7 +70,7 @@ -> NixString -> NValue t f m mkNVStrWithProvenance scopes span x = - addProvenance (Provenance scopes . NStrAnnF span . DoubleQuoted . one . Plain . ignoreContext $ x) $ mkNVStr x + addProvenance (Provenance scopes . NStrAnnF span . DoubleQuoted . one . Plain . ignoreContext $ x) $ NVStr x mkNVPathWithProvenance :: MonadCited t f m @@ -80,7 +80,7 @@ -> Path -> NValue t f m mkNVPathWithProvenance scope span lit real = - addProvenance (Provenance scope . NLiteralPathAnnF span $ lit) $ mkNVPath real + addProvenance (Provenance scope . NLiteralPathAnnF span $ lit) $ NVPath real mkNVClosureWithProvenance :: MonadCited t f m @@ -90,7 +90,7 @@ -> (NValue t f m -> m (NValue t f m)) -> NValue t f m mkNVClosureWithProvenance scopes span x f = - addProvenance (Provenance scopes $ NAbsAnnF span (Nothing <$ x) Nothing) $ mkNVClosure x f + addProvenance (Provenance scopes $ NAbsAnnF span (Nothing <$ x) Nothing) $ NVClosure x f mkNVUnaryOpWithProvenance :: MonadCited t f m @@ -103,6 +103,17 @@ mkNVUnaryOpWithProvenance scope span op val = addProvenance (Provenance scope $ NUnaryAnnF span op val) +mkNVAppOpWithProvenance + :: MonadCited t f m + => Scopes m (NValue t f m) + -> SrcSpan + -> Maybe (NValue t f m) + -> Maybe (NValue t f m) + -> NValue t f m + -> NValue t f m +mkNVAppOpWithProvenance scope span lval rval = + addProvenance (Provenance scope $ NAppAnnF span lval rval) + mkNVBinaryOpWithProvenance :: MonadCited t f m => Scopes m (NValue t f m) @@ -274,7 +285,7 @@ do scope <- askScopes span <- askSpan - mkNVBinaryOpWithProvenance scope span NApp (pure f) Nothing <$> (callFunc f =<< defer x) + mkNVAppOpWithProvenance scope span (pure f) Nothing <$> (callFunc f =<< defer x) evalAbs :: Params (m (NValue t f m)) @@ -309,11 +320,11 @@ fun' <- demand fun case fun' of - NVClosure _params f -> f arg NVBuiltin name f -> do span <- askSpan withFrame Info ((Calling @m @(NValue t f m)) name span) $ f arg -- Is this cool? + NVClosure _params f -> f arg (NVSet _ m) | Just f <- M.lookup "__functor" m -> (`callFunc` arg) =<< (`callFunc` fun') f _x -> throwError $ ErrorCall $ "Attempt to call non-function: " <> show _x @@ -339,7 +350,7 @@ throwError $ ErrorCall $ "argument to unary operator must evaluate to an atomic type: " <> show _x where mkUnaryOp :: (a -> NAtom) -> (a -> a) -> a -> m (NValue t f m) - mkUnaryOp c b a = pure . mkNVUnaryOpWithProvenance scope span op (pure arg) . mkNVConstant $ c (b a) + mkUnaryOp c b a = pure . mkNVUnaryOpWithProvenance scope span op (pure arg) . NVConstant $ c (b a) execBinaryOp :: forall e t f m @@ -390,7 +401,7 @@ toBoolOp :: Maybe (NValue t f m) -> Bool -> m (NValue t f m) toBoolOp r b = - pure $ mkNVBinaryOpWithProvenance scope span op (pure lval) r $ mkNVConstant $ NBool b + pure $ mkNVBinaryOpWithProvenance scope span op (pure lval) r $ NVConstant $ NBool b execBinaryOpForced :: forall e t f m @@ -444,8 +455,6 @@ mkStrP . (ls <>) <$> coerceAnyToNixString callFunc DontCopyToStore rs _ -> unsupportedTypes - - NApp -> throwError $ ErrorCall "NApp should be handled by evalApp" _other -> shouldBeAlreadyHandled where @@ -454,25 +463,25 @@ mkNVBinaryOpWithProvenance scope span op (pure lval) (pure rval) mkBoolP :: Bool -> m (NValue t f m) - mkBoolP = pure . addProv . mkNVConstant . NBool + mkBoolP = pure . addProv . NVConstant . NBool mkIntP :: Integer -> m (NValue t f m) - mkIntP = pure . addProv . mkNVConstant . NInt + mkIntP = pure . addProv . NVConstant . NInt mkFloatP :: Float -> m (NValue t f m) - mkFloatP = pure . addProv . mkNVConstant . NFloat + mkFloatP = pure . addProv . NVConstant . NFloat mkListP :: [NValue t f m] -> NValue t f m - mkListP = addProv . mkNVList + mkListP = addProv . NVList mkStrP :: NixString -> NValue t f m - mkStrP = addProv . mkNVStr + mkStrP = addProv . NVStr mkPathP :: Path -> NValue t f m - mkPathP = addProv . mkNVPath + mkPathP = addProv . NVPath mkSetP :: (PositionSet -> AttrSet (NValue t f m) -> NValue t f m) - mkSetP x s = addProv $ mkNVSet x s + mkSetP x s = addProv $ NVSet x s mkCmpOp :: (forall a. Ord a => a -> a -> Bool) -> m (NValue t f m) mkCmpOp op = case (lval, rval) of diff --git a/src/Nix/Expr/Shorthands.hs b/src/Nix/Expr/Shorthands.hs --- a/src/Nix/Expr/Shorthands.hs +++ b/src/Nix/Expr/Shorthands.hs @@ -68,7 +68,12 @@ mkSelector :: Text -> NAttrPath NExpr mkSelector = one . StaticKey . coerce +-- | Put a binary operator. +-- @since +mkApp :: NExpr -> NExpr -> NExpr +mkApp a = Fix . NApp a -- | Put an unary operator. + -- @since 0.15.0 mkOp :: NUnaryOp -> NExpr -> NExpr mkOp op = Fix . NUnary op @@ -210,7 +215,7 @@ mkFunction :: Params NExpr -> NExpr -> NExpr mkFunction params = Fix . NAbs params --- | General dot-reference with optional alternative if the jey does not exist. +-- | General dot-reference with optional alternative if the key does not exist. -- @since 0.15.0 getRefOrDefault :: Maybe NExpr -> NExpr -> Text -> NExpr getRefOrDefault alt obj = Fix . NSelect alt obj . mkSelector @@ -343,7 +348,7 @@ infix 9 @.<|> -- | Function application (@' '@ in @f x@) -(@@) = mkOp2 NApp +(@@) = mkApp infixl 8 @@ -- | List concatenation: @++@ diff --git a/src/Nix/Expr/Strings.hs b/src/Nix/Expr/Strings.hs --- a/src/Nix/Expr/Strings.hs +++ b/src/Nix/Expr/Strings.hs @@ -72,7 +72,7 @@ where pairWithLast ys = zip - (list + (handlePresence Nothing (pure . Unsafe.last) <$> inits ys @@ -83,7 +83,7 @@ ls' = dropSpaces minIndent <$> ls minIndent = - list + handlePresence 0 (minimum . (countSpaces . mergePlain <$>)) (stripEmptyLines ls) diff --git a/src/Nix/Expr/Types.hs b/src/Nix/Expr/Types.hs --- a/src/Nix/Expr/Types.hs +++ b/src/Nix/Expr/Types.hs @@ -18,7 +18,13 @@ -- [Brief on shallow & deep embedding.](https://web.archive.org/web/20201112031804/https://alessandrovermeulen.me/2013/07/13/the-difference-between-shallow-and-deep-embedding/) -- -- (additiona info for dev): Big use of TemplateHaskell in the module requires proper (top-down) organization of declarations. -module Nix.Expr.Types where +module Nix.Expr.Types + ( module Nix.Expr.Types + , SourcePos(..) + , unPos + , mkPos + ) +where import Nix.Prelude import qualified Codec.Serialise as Serialise @@ -40,10 +46,10 @@ import qualified Language.Haskell.TH.Syntax as TH import Lens.Family2 import Lens.Family2.TH -import Text.Megaparsec.Pos ( SourcePos(SourcePos) - , Pos +import Text.Megaparsec.Pos ( Pos , mkPos , unPos + , SourcePos(SourcePos) ) import Text.Show.Deriving ( deriveShow1, deriveShow2 ) import Text.Read.Deriving ( deriveRead1, deriveRead2 ) @@ -60,57 +66,98 @@ -- * utils +newtype NPos = NPos Pos + deriving + ( Eq, Ord + , Read, Show + , Data, NFData + , Generic + ) + +instance Semigroup NPos where + (NPos x) <> (NPos y) = NPos (x <> y) + +-- | Represents source positions. +-- Source line & column positions change intensively during parsing, +-- so they are declared strict to avoid memory leaks. +-- +-- The data type is a reimplementation of 'Text.Megaparsec.Pos' 'SourcePos'. +data NSourcePos = + NSourcePos + { -- | Name of source file + getSourceName :: Path, + -- | Line number + getSourceLine :: !NPos, + -- | Column number + getSourceColumn :: !NPos + } + deriving + ( Eq, Ord + , Read, Show + , Data, NFData + , Generic + ) + +-- | Helper for 'SourcePos' -> 'NSourcePos' coersion. +toNSourcePos :: SourcePos -> NSourcePos +toNSourcePos (SourcePos f l c) = + NSourcePos (coerce f) (coerce l) (coerce c) + +-- | Helper for 'NSourcePos' -> 'SourcePos' coersion. +toSourcePos :: NSourcePos -> SourcePos +toSourcePos (NSourcePos f l c) = + SourcePos (coerce f) (coerce l) (coerce c) + -- 2021-07-16: NOTE: Should replace @ParamSet@ List -- | > Hashmap VarName -- type synonym type AttrSet = HashMap VarName -- | Holds file positionng information for abstrations. --- A type synonym for @HashMap VarName SourcePos@. -type PositionSet = AttrSet SourcePos +-- A type synonym for @HashMap VarName NSourcePos@. +type PositionSet = AttrSet NSourcePos --- ** orphan instances +-- ** Additional N{,Source}Pos instances -- Placed here because TH inference depends on declaration sequence. --- Upstreaming so far was not pursued. - -instance Serialise Pos where - encode = Serialise.encode . unPos - decode = mkPos <$> Serialise.decode +instance Serialise NPos where + encode = Serialise.encode . unPos . coerce + decode = coerce . mkPos <$> Serialise.decode -instance Serialise SourcePos where - encode (SourcePos f l c) = +instance Serialise NSourcePos where + encode (NSourcePos f l c) = + coerce $ Serialise.encode f <> Serialise.encode l <> Serialise.encode c decode = - liftA3 SourcePos + liftA3 NSourcePos Serialise.decode Serialise.decode Serialise.decode -instance Hashable Pos where - hashWithSalt salt = hashWithSalt salt . unPos +instance Hashable NPos where + hashWithSalt salt = hashWithSalt salt . unPos . coerce -instance Hashable SourcePos where - hashWithSalt salt (SourcePos f l c) = +instance Hashable NSourcePos where + hashWithSalt salt (NSourcePos f l c) = salt `hashWithSalt` f `hashWithSalt` l `hashWithSalt` c -instance Binary Pos where - put = Binary.put . unPos - get = mkPos <$> Binary.get -instance Binary SourcePos +instance Binary NPos where + put = (Binary.put @Int) . unPos . coerce + get = coerce . mkPos <$> Binary.get +instance Binary NSourcePos -instance ToJSON Pos where - toJSON = toJSON . unPos -instance ToJSON SourcePos +instance ToJSON NPos where + toJSON = toJSON . unPos . coerce +instance ToJSON NSourcePos -instance FromJSON Pos where - parseJSON = fmap mkPos . parseJSON -instance FromJSON SourcePos +instance FromJSON NPos where + parseJSON = coerce . fmap mkPos . parseJSON +instance FromJSON NSourcePos -- * Components of Nix expressions @@ -177,7 +224,7 @@ ( Eq, Ord, Generic, Generic1 , Typeable, Data, NFData, NFData1, Serialise, Binary, ToJSON, ToJSON1, FromJSON, FromJSON1 , Functor, Foldable, Traversable - , Show, Hashable + , Show, Read, Hashable ) instance IsString (Params r) where @@ -405,23 +452,23 @@ -- | A single line of the bindings section of a let expression or of a set. data Binding r - = NamedVar !(NAttrPath r) !r !SourcePos + = NamedVar !(NAttrPath r) !r !NSourcePos -- ^ An explicit naming. -- - -- > NamedVar (StaticKey "x" :| [StaticKey "y"]) z SourcePos{} ~ x.y = z; - | Inherit !(Maybe r) ![VarName] !SourcePos + -- > NamedVar (StaticKey "x" :| [StaticKey "y"]) z NSourcePos{} ~ x.y = z; + | Inherit !(Maybe r) ![VarName] !NSourcePos -- ^ Inheriting an attribute (binding) into the attribute set from the other scope (attribute set). No denoted scope means to inherit from the closest outside scope. -- - -- +---------------------------------------------------------------+--------------------+-----------------------+ - -- | Hask | Nix | pseudocode | - -- +===============================================================+====================+=======================+ - -- | @Inherit Nothing [StaticKey "a"] SourcePos{}@ | @inherit a;@ | @a = outside.a;@ | - -- +---------------------------------------------------------------+--------------------+-----------------------+ - -- | @Inherit (pure x) [StaticKey "a"] SourcePos{}@ | @inherit (x) a;@ | @a = x.a;@ | - -- +---------------------------------------------------------------+--------------------+-----------------------+ - -- | @Inherit (pure x) [StaticKey "a", StaticKey "b"] SourcePos{}@ | @inherit (x) a b;@ | @a = x.a;@ | - -- | | | @b = x.b;@ | - -- +---------------------------------------------------------------+--------------------+-----------------------+ + -- +----------------------------------------------------------------+--------------------+-----------------------+ + -- | Hask | Nix | pseudocode | + -- +================================================================+====================+=======================+ + -- | @Inherit Nothing [StaticKey "a"] NSourcePos{}@ | @inherit a;@ | @a = outside.a;@ | + -- +----------------------------------------------------------------+--------------------+-----------------------+ + -- | @Inherit (pure x) [StaticKey "a"] NSourcePos{}@ | @inherit (x) a;@ | @a = x.a;@ | + -- +----------------------------------------------------------------+--------------------+-----------------------+ + -- | @Inherit (pure x) [StaticKey "a", StaticKey "b"] NSourcePos{}@ | @inherit (x) a b;@ | @a = x.a;@ | + -- | | | @b = x.b;@ | + -- +----------------------------------------------------------------+--------------------+-----------------------+ -- -- (2021-07-07 use details): -- Inherits the position of the first name through @unsafeGetAttrPos@. The position of the scope inherited from else - the position of the first member of the binds list. @@ -480,7 +527,6 @@ $(makeTraversals ''NUnaryOp) - -- ** data NBinaryOp -- | Binary operators expressible in the nix language. @@ -500,9 +546,6 @@ | NMult -- ^ Multiplication (@*@) | NDiv -- ^ Division (@/@) | NConcat -- ^ List concatenation (@++@) - | NApp -- ^ Apply a function to an argument. - -- - -- > NBinary NApp f x ~ f x deriving ( Eq, Ord, Enum, Bounded, Generic , Typeable, Data, NFData, Serialise, Binary, ToJSON, FromJSON @@ -551,6 +594,10 @@ -- environment variable. For example, @@. -- -- > NEnvPath "x" ~ + | NApp !r !r + -- ^ Functional application (aka F.A., apply a function to an argument). + -- + -- > NApp f x ~ f x | NUnary !NUnaryOp !r -- ^ Application of a unary operator to an expression. -- @@ -701,8 +748,8 @@ erasePositions (NamedVar path r _pos) = NamedVar path r nullPos erasePositions (Inherit ms names _pos) = Inherit ms names nullPos -nullPos :: SourcePos -nullPos = on (SourcePos "") mkPos 1 1 +nullPos :: NSourcePos +nullPos = on (NSourcePos "") (coerce . mkPos) 1 1 -- * Dead code @@ -718,7 +765,7 @@ :: forall ann g . NExprAnn ann g => NonEmpty VarName - -> SourcePos + -> NSourcePos -> Lens' (Fix g) (Maybe (Fix g)) ekey keys pos f e@(Fix x) | (NSet NonRecursive xs, ann) <- fromNExpr x = @@ -728,7 +775,7 @@ do let keys' = NE.toList keys (ks, rest) <- zip (inits keys') (tails keys') - list + handlePresence mempty (\ (j : js) -> do @@ -765,6 +812,7 @@ (NLiteralPath _ ) -> mempty (NEnvPath _ ) -> mempty (NUnary _ expr ) -> getFreeVars expr + (NApp left right ) -> collectFreeVars left right (NBinary _ left right ) -> collectFreeVars left right (NSelect orExpr expr path) -> Set.unions diff --git a/src/Nix/Expr/Types/Annotated.hs b/src/Nix/Expr/Types/Annotated.hs --- a/src/Nix/Expr/Types/Annotated.hs +++ b/src/Nix/Expr/Types/Annotated.hs @@ -10,9 +10,6 @@ module Nix.Expr.Types.Annotated ( module Nix.Expr.Types.Annotated , module Data.Functor.Compose - , SourcePos(..) - , unPos - , mkPos ) where @@ -35,10 +32,6 @@ import GHC.Generics import Nix.Atoms import Nix.Expr.Types -import Text.Megaparsec ( unPos - , mkPos - ) -import Text.Megaparsec.Pos ( SourcePos(..) ) import Text.Read.Deriving import Text.Show.Deriving @@ -46,8 +39,8 @@ -- | Demarcation of a chunk in a source file. data SrcSpan = SrcSpan - { spanBegin :: SourcePos - , spanEnd :: SourcePos + { getSpanBegin :: NSourcePos + , getSpanEnd :: NSourcePos } deriving (Ord, Eq, Generic, Typeable, Data, Show, NFData, Hashable) @@ -56,8 +49,8 @@ instance Semigroup SrcSpan where s1 <> s2 = SrcSpan - (on min spanBegin s1 s2) - (on max spanEnd s1 s2) + (on min getSpanBegin s1 s2) + (on max getSpanEnd s1 s2) instance Binary SrcSpan instance ToJSON SrcSpan @@ -175,7 +168,7 @@ annNHasAttr e1@(Ann s1 _) (AnnUnit s2 ats) = NHasAttrAnn (s1 <> s2) e1 ats annNApp :: NExprLoc -> NExprLoc -> NExprLoc -annNApp e1@(Ann s1 _) e2@(Ann s2 _) = NBinaryAnn (s1 <> s2) NApp e1 e2 +annNApp e1@(Ann s1 _) e2@(Ann s2 _) = NAppAnn (s1 <> s2) e1 e2 annNAbs :: AnnUnit SrcSpan (Params NExprLoc) -> NExprLoc -> NExprLoc annNAbs (AnnUnit s1 ps) e1@(Ann s2 _) = NAbsAnn (s1 <> s2) ps e1 @@ -183,8 +176,8 @@ annNStr :: AnnUnit SrcSpan (NString NExprLoc) -> NExprLoc annNStr (AnnUnit s1 s) = NStrAnn s1 s -deltaInfo :: SourcePos -> (Text, Int, Int) -deltaInfo (SourcePos fp l c) = (fromString fp, unPos l, unPos c) +deltaInfo :: NSourcePos -> (Text, Int, Int) +deltaInfo (NSourcePos fp l c) = (fromString $ coerce fp, unPos $ coerce l, unPos $ coerce c) annNNull :: NExprLoc annNNull = NConstantAnn nullSpan NNull @@ -194,8 +187,10 @@ nullSpan = SrcSpan nullPos nullPos {-# inline nullSpan #-} --- | Pattern systems for matching on @NExprLocF@ constructions. +-- ** Patterns +-- *** Patterns to match on 'NExprLocF' constructions (for 'SrcSpan'-based annotations). + pattern NConstantAnnF :: SrcSpan -> NAtom -> NExprLocF r pattern NConstantAnnF ann x = AnnF ann (NConstant x) @@ -220,6 +215,9 @@ pattern NUnaryAnnF :: SrcSpan -> NUnaryOp -> r -> NExprLocF r pattern NUnaryAnnF ann op x = AnnF ann (NUnary op x) +pattern NAppAnnF :: SrcSpan -> r -> r -> NExprLocF r +pattern NAppAnnF ann x y = AnnF ann (NApp x y) + pattern NBinaryAnnF :: SrcSpan -> NBinaryOp -> r -> r -> NExprLocF r pattern NBinaryAnnF ann op x y = AnnF ann (NBinary op x y) @@ -249,6 +247,8 @@ {-# complete NConstantAnnF, NStrAnnF, NSymAnnF, NListAnnF, NSetAnnF, NLiteralPathAnnF, NEnvPathAnnF, NUnaryAnnF, NBinaryAnnF, NSelectAnnF, NHasAttrAnnF, NAbsAnnF, NLetAnnF, NIfAnnF, NWithAnnF, NAssertAnnF, NSynHoleAnnF #-} +-- *** Patterns to match on 'NExprLoc' constructions (for 'SrcSpan'-based annotations). + pattern NConstantAnn :: SrcSpan -> NAtom -> NExprLoc pattern NConstantAnn ann x = Ann ann (NConstant x) @@ -272,6 +272,9 @@ pattern NUnaryAnn :: SrcSpan -> NUnaryOp -> NExprLoc -> NExprLoc pattern NUnaryAnn ann op x = Ann ann (NUnary op x) + +pattern NAppAnn :: SrcSpan -> NExprLoc -> NExprLoc -> NExprLoc +pattern NAppAnn ann x y = Ann ann (NApp x y) pattern NBinaryAnn :: SrcSpan -> NBinaryOp -> NExprLoc -> NExprLoc -> NExprLoc pattern NBinaryAnn ann op x y = Ann ann (NBinary op x y) diff --git a/src/Nix/Fresh.hs b/src/Nix/Fresh.hs --- a/src/Nix/Fresh.hs +++ b/src/Nix/Fresh.hs @@ -14,7 +14,7 @@ , MonadMask , MonadThrow ) -import Control.Monad.Except ( MonadFix ) +import Control.Monad.Fix ( MonadFix ) import Control.Monad.Ref ( MonadAtomicRef(..) , MonadRef(Ref) ) diff --git a/src/Nix/Json.hs b/src/Nix/Json.hs --- a/src/Nix/Json.hs +++ b/src/Nix/Json.hs @@ -25,8 +25,8 @@ toEncodingSorted = \case A.Object m -> A.pairs - . fold - . ((\(k, v) -> A.pair k $ toEncodingSorted v) <$>) + . foldMap + (\(k, v) -> A.pair k $ toEncodingSorted v) . sortWith fst $ #if MIN_VERSION_aeson(2,0,0) AKM.toList diff --git a/src/Nix/Lint.hs b/src/Nix/Lint.hs --- a/src/Nix/Lint.hs +++ b/src/Nix/Lint.hs @@ -1,7 +1,6 @@ {-# language ConstraintKinds #-} {-# language CPP #-} {-# language DataKinds #-} -{-# language GADTs #-} {-# language GeneralizedNewtypeDeriving #-} {-# language TypeFamilies #-} {-# language UndecidableInstances #-} @@ -105,6 +104,12 @@ -> m (Symbolic m) mkSymbolic = packSymbolic . NMany +mkSymbolic1 + :: MonadAtomicRef m + => NTypeF m (Symbolic m) + -> m (Symbolic m) +mkSymbolic1 = mkSymbolic . one + packSymbolic :: MonadAtomicRef m => NSymbolicF (NTypeF m (Symbolic m)) @@ -158,7 +163,7 @@ do (args, sym) <- do - f' <- mkSymbolic $ one f + f' <- mkSymbolic1 f lintApp (NAbs p mempty) f' everyPossible args' <- traverse renderSymbolic args sym' <- renderSymbolic sym @@ -170,9 +175,9 @@ ) <=< unpackSymbolic where between a b c = a <> b <> c - parens = between "(" ")" + parens = between "(" ")" brackets = between "[" "]" - braces = between "{" "}" + braces = between "{" "}" -- This function is order and uniqueness preserving (of types). merge @@ -204,19 +209,21 @@ (TSet x , TSet Nothing ) -> (one (TSet x) <>) <$> rest (TSet Nothing , TSet x ) -> (one (TSet x) <>) <$> rest (TSet (Just l), TSet (Just r)) -> do - m <- sequenceA $ M.intersectionWith - (\ i j -> - do - i'' <- demand =<< i - j'' <- demand =<< j - (defer . unify context i'') j'' - ) - (pure <$> l) - (pure <$> r) - bool + hm <- + sequenceA $ + M.intersectionWith + (\ i j -> + do + i'' <- i + j'' <- j + defer $ unify context i'' j'' + ) + (fmap demand l) + (fmap demand r) + handlePresence id - ((one (TSet $ pure m) <>) <$>) - (not $ M.null m) + (const ((one (TSet $ pure hm) <>) <$>)) + hm rest (TClosure{}, TClosure{}) -> @@ -251,40 +258,42 @@ -- | Result @== NMany []@ -> @unify@ fails. unify - :: forall e m + :: forall e m a . MonadLint e m - => NExprF () + => NExprF a -> Symbolic m -> Symbolic m -> m (Symbolic m) -unify context (SV x) (SV y) = do +unify (void -> context) (SV x) (SV y) = do x' <- readRef x y' <- readRef y case (x', y') of - (NAny, _) -> do - writeRef x y' - pure $ SV y - (_, NAny) -> do - writeRef y x' - pure $ SV x - (NMany xs, NMany ys) -> do - m <- merge context xs ys - bool - (do - let - nm = NMany m - writeRef x nm - writeRef y nm - packSymbolic nm - ) + (NAny, _) -> + do + writeRef x y' + pure $ SV y + (_, NAny) -> + do + writeRef y x' + pure $ SV x + (NMany xs, NMany ys) -> + handlePresence ( - -- x' <- renderSymbolic (Symbolic x) - -- y' <- renderSymbolic (Symbolic y) + -- x' <- renderSymbolic (Symbolic x) + -- y' <- renderSymbolic (Symbolic y) throwError $ ErrorCall "Cannot unify " -- <> show x' <> " with " <> show y' -- <> " in context: " <> show context ) - (null m) + (\ m -> + do + let + nm = NMany m + writeRef x nm + writeRef y nm + packSymbolic nm + ) + =<< merge context xs ys unify _ _ _ = error "The unexpected hath transpired!" -- These aren't worth defining yet, because once we move to Hindley-Milner, @@ -323,7 +332,7 @@ freeVariable var = symerr $ "Undefined variable '" <> coerce var <> "'" attrMissing ks ms = - evalError @(Symbolic m) $ ErrorCall $ toString $ + evalError @(Symbolic m) . ErrorCall . toString $ maybe ("Inheriting unknown attribute: " <> attr) (\ s -> "Could not look up attribute " <> attr <> " in " <> show s) @@ -331,13 +340,14 @@ where attr = Text.intercalate "." $ NE.toList $ coerce ks - evalCurPos = do - f <- mkSymbolic $ one TPath - l <- mkSymbolic $ one $ TConstant $ one TInt - c <- mkSymbolic $ one $ TConstant $ one TInt - mkSymbolic $ one $ TSet (pure (M.fromList [("file", f), ("line", l), ("col", c)])) + evalCurPos = + do + f <- mkSymbolic1 TPath + l <- mkSymbolic1 $ TConstant $ one TInt + c <- mkSymbolic1 $ TConstant $ one TInt + mkSymbolic1 $ TSet . pure $ M.fromList [("file", f), ("line", l), ("col", c)] - evalConstant c = mkSymbolic $ one $ fun c + evalConstant c = mkSymbolic1 $ fun c where fun = \case @@ -347,12 +357,12 @@ NBool _ -> TConstant $ one TBool NNull -> TConstant $ one TNull - evalString = const $ mkSymbolic $ one TStr - evalLiteralPath = const $ mkSymbolic $ one TPath - evalEnvPath = const $ mkSymbolic $ one TPath + evalString = const $ mkSymbolic1 TStr + evalLiteralPath = const $ mkSymbolic1 TPath + evalEnvPath = const $ mkSymbolic1 TPath evalUnary op arg = - unify (void $ NUnary op arg) arg =<< mkSymbolic (one $ TConstant [TInt, TBool]) + unify (NUnary op arg) arg =<< mkSymbolic1 (TConstant [TInt, TBool]) evalBinary = lintBinaryOp @@ -376,20 +386,16 @@ do t' <- t f' <- f - let e = NIf cond t' f' - - _ <- unify (void e) cond =<< mkSymbolic (one $ TConstant $ one TBool) - unify (void e) t' f' + let e = unify (NIf cond t' f') + e t' f' <* (e cond =<< mkSymbolic1 (TConstant $ one TBool)) evalAssert cond body = do body' <- body - let e = NAssert cond body' - _ <- unify (void e) cond =<< mkSymbolic (one $ TConstant $ one TBool) - pure body' + body' <$ (unify (NAssert cond body') cond =<< mkSymbolic1 (TConstant $ one TBool)) - evalApp = (fmap snd .) . lintApp (join (NBinary NApp) mempty) - evalAbs params _ = mkSymbolic (one $ TClosure $ void params) + evalApp = (fmap snd .) . lintApp (join NApp mempty) + evalAbs params _ = mkSymbolic1 (TClosure $ void params) evalError = throwError @@ -405,33 +411,31 @@ rsym <- rarg y <- defer everyPossible - case op of - NApp -> symerr "lintBinaryOp:NApp: should never get here" - _ -> check lsym rsym $ - case op of - NEq -> [TConstant [TInt, TBool, TNull], TStr, TList y] - NNEq -> [TConstant [TInt, TBool, TNull], TStr, TList y] + check lsym rsym $ + case op of + NEq -> [TConstant [TInt, TBool, TNull], TStr, TList y] + NNEq -> [TConstant [TInt, TBool, TNull], TStr, TList y] - NLt -> one $ TConstant [TInt, TBool, TNull] - NLte -> one $ TConstant [TInt, TBool, TNull] - NGt -> one $ TConstant [TInt, TBool, TNull] - NGte -> one $ TConstant [TInt, TBool, TNull] + NLt -> one $ TConstant [TInt, TBool, TNull] + NLte -> one $ TConstant [TInt, TBool, TNull] + NGt -> one $ TConstant [TInt, TBool, TNull] + NGte -> one $ TConstant [TInt, TBool, TNull] - NAnd -> one $ TConstant $ one TBool - NOr -> one $ TConstant $ one TBool - NImpl -> one $ TConstant $ one TBool + NAnd -> one $ TConstant $ one TBool + NOr -> one $ TConstant $ one TBool + NImpl -> one $ TConstant $ one TBool - -- jww (2018-04-01): NYI: Allow Path + Str - NPlus -> [TConstant $ one TInt, TStr, TPath] - NMinus -> one $ TConstant $ one TInt - NMult -> one $ TConstant $ one TInt - NDiv -> one $ TConstant $ one TInt + -- jww (2018-04-01): NYI: Allow Path + Str + NPlus -> [TConstant $ one TInt, TStr, TPath] + NMinus -> one $ TConstant $ one TInt + NMult -> one $ TConstant $ one TInt + NDiv -> one $ TConstant $ one TInt - NUpdate -> one $ TSet mempty + NUpdate -> one $ TSet mempty - NConcat -> one $ TList y -#if __GLASGOW_HASKELL__ < 900 - _ -> fail "Should not be possible" -- symerr or this fun signature should be changed to work in type scope + NConcat -> one $ TList y +#if __GLASGOW_HASKELL__ < 810 + _ -> fail "Should not be possible" -- symerr or this fun signature should be changed to work in type scope #endif @@ -440,13 +444,12 @@ check lsym rsym xs = do let - e = NBinary op lsym rsym - unifyE = unify (void e) + contextUnify = unify $ NBinary op lsym rsym m <- mkSymbolic xs - _ <- unifyE lsym m - _ <- unifyE rsym m - unifyE lsym rsym + _ <- contextUnify lsym m + _ <- contextUnify rsym m + contextUnify lsym rsym infixl 1 `lintApp` lintApp @@ -460,24 +463,26 @@ (\case NAny -> throwError $ ErrorCall "Cannot apply something not known to be a function" - NMany xs -> do - (args, ys) <- fmap unzip $ forM xs $ \case - TClosure _params -> - (\case - NAny -> do - error "NYI" - - NMany [TSet (Just _)] -> do - error "NYI" - - NMany _ -> throwError $ ErrorCall "NYI: lintApp NMany not set" - ) =<< unpackSymbolic =<< arg - TBuiltin _ _f -> throwError $ ErrorCall "NYI: lintApp builtin" - TSet _m -> throwError $ ErrorCall "NYI: lintApp Set" - _x -> throwError $ ErrorCall "Attempt to call non-function" + NMany xs -> + do + (args, ys) <- + unzip <$> + traverse + (\case + TClosure _params -> + (\case + NAny -> error "NYI" + NMany [TSet (Just _)] -> error "NYI" + NMany _ -> throwError $ ErrorCall "NYI: lintApp NMany not set" + ) =<< unpackSymbolic =<< arg + TBuiltin _ _f -> throwError $ ErrorCall "NYI: lintApp builtin" + TSet _m -> throwError $ ErrorCall "NYI: lintApp Set" + _x -> throwError $ ErrorCall "Attempt to call non-function" + ) + xs - y <- everyPossible - (Unsafe.head args, ) <$> foldM (unify context) y ys + y <- everyPossible + (Unsafe.head args, ) <$> foldM (unify context) y ys ) =<< unpackSymbolic fun newtype Lint s a = Lint @@ -498,7 +503,7 @@ throwM e = Lint $ ReaderT $ const (throw e) instance MonadCatch (Lint s) where - catch _m _h = Lint $ ReaderT $ const (fail "Cannot catch in 'Lint s'") + catch _m _h = Lint $ ReaderT $ const (error "Cannot catch in 'Lint s'") runLintM :: Options -> Lint s a -> ST s a runLintM opts action = diff --git a/src/Nix/Normal.hs b/src/Nix/Normal.hs --- a/src/Nix/Normal.hs +++ b/src/Nix/Normal.hs @@ -1,7 +1,6 @@ {-# language AllowAmbiguousTypes #-} {-# language ConstraintKinds #-} {-# language DataKinds #-} -{-# language GADTs #-} {-# language TypeFamilies #-} {-# language RankNTypes #-} @@ -35,39 +34,42 @@ ) => NValue t f m -> m (NValue t f m) -normalizeValue v = run $ iterNValueM run (flip go) (fmap Free . sequenceNValue' run) v +normalizeValue v = run $ iterNValueM run go (fmap Free . sequenceNValue' run) v where start = 0 :: Int + maxDepth = 2000 table = mempty run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r run = (`evalStateT` table) . (`runReaderT` start) go - :: t - -> ( NValue t f m + :: ( NValue t f m -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m) ) + -> t -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m) - go t k = do - b <- seen t + go k tnk = bool (do i <- ask - when (i > 2000) $ fail "Exceeded maximum normalization depth of 2000 levels" + when (i > maxDepth) $ fail $ "Exceeded maximum normalization depth of " <> show maxDepth <> " levels." (lifted . lifted) - (=<< force t) - (local succ . k) + (=<< force tnk) + (local (+1) . k) ) - (pure $ pure t) - b - - seen t = do - let tid = thunkId t - lift $ do - res <- gets $ member tid - unless res $ modify $ insert tid - pure res + (pure $ pure tnk) + =<< seen tnk + where + seen :: t -> ReaderT Int (StateT (Set (ThunkId m)) m) Bool + seen t = + do + let tnkid = thunkId t + lift $ + do + thunkWasVisited <- gets $ member tnkid + when (not thunkWasVisited) $ modify $ insert tnkid + pure thunkWasVisited -- 2021-05-09: NOTE: This seems a bit excessive. If these functorial versions are not used for recursion schemes - just free from it. -- | Normalization HOF (functorial) version of @normalizeValue@. Accepts the special thunk operating/forcing/nirmalizing function & internalizes it. @@ -81,39 +83,42 @@ => (forall r . t -> (NValue t f m -> m r) -> m r) -> NValue t f m -> m (NValue t f m) -normalizeValueF f = run . iterNValueM run (flip go) (fmap Free . sequenceNValue' run) +normalizeValueF f = run . iterNValueM run go (fmap Free . sequenceNValue' run) where start = 0 :: Int + maxDepth = 2000 table = mempty run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r run = (`evalStateT` table) . (`runReaderT` start) go - :: t - -> ( NValue t f m + :: ( NValue t f m -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m) ) + -> t -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m) - go t k = do - b <- seen t + go k tnk = bool (do i <- ask - when (i > 2000) $ fail "Exceeded maximum normalization depth of 2000 levels" + when (i > maxDepth) $ fail $ "Exceeded maximum normalization depth of " <> show maxDepth <> " levels." (lifted . lifted) - (f t) - (local succ . k) + (f tnk) + (local (+1) . k) ) - (pure $ pure t) - b - - seen t = do - let tid = thunkId t - lift $ do - res <- gets $ member tid - unless res $ modify $ insert tid - pure res + (pure $ pure tnk) + =<< seen tnk + where + seen :: t -> ReaderT Int (StateT (Set (ThunkId m)) m) Bool + seen t = + do + let tnkid = thunkId t + lift $ + do + thunkWasVisited <- gets $ member tnkid + when (not thunkWasVisited) $ modify $ insert tnkid + pure thunkWasVisited -- | Normalize value. -- Detect cycles. @@ -141,7 +146,7 @@ -> m () normalForm_ t = void $ normalizeValue t -opaqueVal :: Applicative f => NValue t f m +opaqueVal :: NVConstraint f => NValue t f m opaqueVal = mkNVStrWithoutContext "" -- | Detect cycles & stub them. @@ -167,14 +172,14 @@ where Free (NValue' cyc) = opaqueVal -thunkStubVal :: Applicative f => NValue t f m +thunkStubVal :: NVConstraint f => NValue t f m thunkStubVal = mkNVStrWithoutContext thunkStubText -- | Check if thunk @t@ is computed, -- then bind it into first arg. -- else bind the thunk stub val. bindComputedThunkOrStub - :: ( Applicative f + :: ( NVConstraint f , MonadThunk t m (NValue t f m) ) => (NValue t f m -> m a) diff --git a/src/Nix/Parser.hs b/src/Nix/Parser.hs --- a/src/Nix/Parser.hs +++ b/src/Nix/Parser.hs @@ -15,13 +15,11 @@ , parseFromText , Result , reservedNames - , OperatorInfo(..) - , NSpecialOp(..) , NAssoc(..) - , NOperatorDef - , getUnaryOperator - , getBinaryOperator - , getSpecialOperator + , NOpPrecedence(..) + , NOpName(..) + , NSpecialOp(..) + , NOperatorDef(..) , nixExpr , nixExprAlgebra , nixSet @@ -37,6 +35,10 @@ , nixBool , nixNull , whiteSpace + + -- 2022-01-26: NOTE: Try to hide it after OperatorInfo is removed + , NOp(..) + , appOpDef ) where @@ -60,9 +62,9 @@ , isSpace ) import Data.Data ( Data(..) ) +import Data.List.Extra ( groupSort ) import Data.Fix ( Fix(..) ) import qualified Data.HashSet as HashSet -import qualified Data.Map as Map import qualified Data.Text as Text import Nix.Expr.Types import Nix.Expr.Shorthands hiding ( ($>) ) @@ -97,7 +99,7 @@ isAlphanumeric x = isAlpha x || isDigit x {-# inline isAlphanumeric #-} --- | @<|>@ with additional preservation of @MonadPlus@ constraint. +-- | Alternative "<|>" with additional preservation of 'MonadPlus' constraint. infixl 3 <|> (<|>) :: MonadPlus m => m a -> m a -> m a (<|>) = mplus @@ -108,10 +110,10 @@ annotateLocation1 p = do begin <- getSourcePos - res <- p + res <- p end <- get -- The state set before the last whitespace - pure $ AnnUnit (SrcSpan begin end) res + pure $ AnnUnit (SrcSpan (toNSourcePos begin) (toNSourcePos end)) res annotateLocation :: Parser (NExprF NExprLoc) -> Parser NExprLoc annotateLocation = (annUnitToAnn <$>) . annotateLocation1 @@ -136,14 +138,11 @@ reserved n = lexeme $ try $ chunk n *> lookAhead (void (satisfy reservedEnd) <|> eof) -exprAfterP :: Parser a -> Parser NExprLoc -exprAfterP p = p *> nixExpr - exprAfterSymbol :: Char -> Parser NExprLoc -exprAfterSymbol p = exprAfterP $ symbol p +exprAfterSymbol p = symbol p *> nixExpr exprAfterReservedWord :: Text -> Parser NExprLoc -exprAfterReservedWord word = exprAfterP $ reserved word +exprAfterReservedWord word = reserved word *> nixExpr -- | A literal copy of @megaparsec@ one but with addition of the @\r@ for Windows EOL case (@\r\n@). -- Overall, parser should simply @\r\n -> \n@. @@ -173,7 +172,7 @@ symbols = lexeme . chunk -- We restrict the type of 'parens' and 'brackets' here because if they were to --- take a @Parser NExprLoc@ argument they would parse additional text which +-- take a 'Parser NExprLoc' argument they would parse additional text which -- wouldn't be captured in the source location annotation. -- -- Braces and angles in hnix don't enclose a single expression so this type @@ -320,17 +319,16 @@ try $ do indentedQuotationMark - (Plain <$> ("''" <$ char '\'' <|> "$" <$ char '$')) + Plain <$> ("''" <$ char '\'' <|> "$" <$ char '$') <|> do - _ <- char '\\' - c <- escapeCode + c <- char '\\' *> escapeCode pure $ bool EscapedNewline (Plain $ one c) - (c /= '\n') + ('\n' /= c) -- | Enclosed into indented quatation "'' ''" inIndentedQuotation :: Parser a -> Parser a @@ -401,7 +399,7 @@ label "inherited binding" $ liftA2 (Inherit x) (many identifier) - (pure p) + (pure (toNSourcePos p)) namedVar = do p <- getSourcePos @@ -409,7 +407,7 @@ liftA3 NamedVar (annotated <$> nixSelector) (exprAfterSymbol '=') - (pure p) + (pure (toNSourcePos p)) scope = label "inherit scope" nixParens nixSet :: Parser NExprLoc @@ -464,23 +462,19 @@ -- ** Operators -data NSpecialOp = NHasAttrOp | NSelectOp - deriving (Eq, Ord, Generic, Typeable, Data, Show, NFData) - -data NAssoc = NAssocNone | NAssocLeft | NAssocRight - deriving (Eq, Ord, Generic, Typeable, Data, Show, NFData) +-- 2022-01-26: NOTE: Rename to 'literal' +newtype NOpName = NOpName Text + deriving + (Eq, Ord, Generic, Typeable, Data, Show, NFData) -data NOperatorDef - = NUnaryDef NUnaryOp Text - | NBinaryDef NAssoc NBinaryOp Text - | NSpecialDef NAssoc NSpecialOp Text - deriving (Eq, Ord, Generic, Typeable, Data, Show, NFData) +instance IsString NOpName where + fromString = coerce . fromString @Text -manyUnaryOp :: MonadPlus f => f (a -> a) -> f (a -> a) -manyUnaryOp f = foldr1 (.) <$> some f +instance ToString NOpName where + toString = toString @Text . coerce -operator :: Text -> Parser Text -operator op = +operator :: NOpName -> Parser Text +operator (coerce -> op) = case op of c@"-" -> c `without` '>' c@"/" -> c `without` '/' @@ -492,173 +486,210 @@ without opChar noNextChar = lexeme . try $ chunk opChar <* notFollowedBy (char noNextChar) -opWithLoc :: (AnnUnit SrcSpan o -> a) -> o -> Text -> Parser a -opWithLoc f op name = - do - AnnUnit ann _ <- - annotateLocation1 $ - operator name +opWithLoc :: (AnnUnit SrcSpan o -> a) -> o -> NOpName -> Parser a +opWithLoc f op name = f . (op <$) <$> annotateLocation1 (operator name) - pure . f $ AnnUnit ann op +-- 2022-01-26: NOTE: Make presedence free and type safe by moving it into type level: +-- https://youtu.be/qaPdg0mZavM?t=1757 +-- https://wiki.haskell.org/The_Monad.Reader/Issue5/Number_Param_Types +newtype NOpPrecedence = NOpPrecedence Int + deriving (Eq, Ord, Generic, Bounded, Typeable, Data, Show, NFData) -binary - :: NAssoc - -> (Parser (NExprLoc -> NExprLoc -> NExprLoc) -> b) - -> NBinaryOp - -> Text - -> (NOperatorDef, b) -binary assoc fixity op name = - (NBinaryDef assoc op name, fixity $ opWithLoc annNBinary op name) +instance Enum NOpPrecedence where + toEnum = coerce + fromEnum = coerce -binaryN, binaryL, binaryR :: NBinaryOp -> Text -> (NOperatorDef, Operator Parser NExprLoc) -binaryN = - binary NAssocNone InfixN -binaryL = - binary NAssocLeft InfixL -binaryR = - binary NAssocRight InfixR +instance Num NOpPrecedence where + (+) = coerce ((+) @Int) + (*) = coerce ((*) @Int) + abs = coerce (abs @Int) + signum = coerce (signum @Int) + fromInteger = coerce (fromInteger @Int) + negate = coerce (negate @Int) -prefix :: NUnaryOp -> Text -> (NOperatorDef, Operator Parser NExprLoc) -prefix op name = - (NUnaryDef op name, Prefix $ manyUnaryOp $ opWithLoc annNUnary op name) --- postfix name op = (NUnaryDef name op, --- Postfix (opWithLoc name op annNUnary)) +-- 2022-01-26: NOTE: This type belongs into 'Type.Expr' & be used in NExprF. +data NAppOp = NAppOp + deriving (Eq, Ord, Generic, Typeable, Data, Show, NFData) -nixOperators - :: Parser (AnnUnit SrcSpan (NAttrPath NExprLoc)) - -> [[ ( NOperatorDef - , Operator Parser NExprLoc - ) - ]] -nixOperators selector = - [ -- This is not parsed here, even though technically it's part of the - -- expression table. The problem is that in some cases, such as list - -- membership, it's also a term. And since terms are effectively the - -- highest precedence entities parsed by the expression parser, it ends up - -- working out that we parse them as a kind of "meta-term". +-- 2022-01-26: NOTE: This type belongs into 'Type.Expr' & be used in NExprF. +data NSpecialOp + = NHasAttrOp + | NSelectOp + | NTerm -- ^ For special handling of internal special cases. + deriving (Eq, Ord, Generic, Typeable, Data, Show, NFData) - -- {- 1 -} - -- [ ( NSpecialDef "." NSelectOp NAssocLeft - -- , Postfix $ - -- do - -- sel <- seldot *> selector - -- mor <- optional (reserved "or" *> term) - -- pure $ \x -> annNSelect x sel mor) - -- ] +data NAssoc + = NAssocLeft + -- Nota bene: @parser-combinators@ named "associative property" as 'InfixN' stating it as "non-associative property". + -- Binary operators having some associativity is a basis property in mathematical algebras in use (for example, in Category theory). Having no associativity in operators makes theory mostly impossible in use and so non-associativity is not encountered in notations, therefore under 'InfixN' @parser-combinators@ meant "associative". + -- | Bidirectional associativity, or simply: associative property. + | NAssoc + | NAssocRight + deriving (Eq, Ord, Generic, Typeable, Data, Show, NFData) - {- 2 -} - one - ( NBinaryDef NAssocLeft NApp " " - , - -- Thanks to Brent Yorgey for showing me this trick! - InfixL $ annNApp <$ symbols mempty - ) - , {- 3 -} - one $ prefix NNeg "-" - , {- 4 -} - one - ( NSpecialDef NAssocLeft NHasAttrOp "?" - , Postfix $ symbol '?' *> (flip annNHasAttr <$> selector) - ) - , {- 5 -} - one $ binaryR NConcat "++" - , {- 6 -} - [ binaryL NMult "*" - , binaryL NDiv "/" - ] - , {- 7 -} - [ binaryL NPlus "+" - , binaryL NMinus "-" - ] - , {- 8 -} - one $ prefix NNot "!" - , {- 9 -} - one $ binaryR NUpdate "//" - , {- 10 -} - [ binaryL NLt "<" - , binaryL NGt ">" - , binaryL NLte "<=" - , binaryL NGte ">=" - ] - , {- 11 -} - [ binaryN NEq "==" - , binaryN NNEq "!=" - ] - , {- 12 -} - one $ binaryL NAnd "&&" - , {- 13 -} - one $ binaryL NOr "||" - , {- 14 -} - one $ binaryR NImpl "->" - ] +-- 2022-01-31: NOTE: This type and related typeclasses & their design, probably need a refinement. +-- +-- In the "Nix.Pretty", the code probably should be well-typed to the type of operations its processes. +-- Therefor splitting operation types into separate types there is probably needed. +-- +-- After that: +-- +-- > { NAssoc, NOpPrecedence, NOpName } +-- +-- Can be formed into a type. +-- +-- Also 'NAppDef' really has only 1 implementation, @{ NAssoc, NOpPrecedence, NOpName }@ +-- were added there only to make type uniformal. +-- All impossible cases ideally should be unrepresentable. +-- | Single operator grammar entries. +data NOperatorDef + = NAppDef NAppOp NAssoc NOpPrecedence NOpName + | NUnaryDef NUnaryOp NAssoc NOpPrecedence NOpName + | NBinaryDef NBinaryOp NAssoc NOpPrecedence NOpName + | NSpecialDef NSpecialOp NAssoc NOpPrecedence NOpName + -- 2022-01-26: NOTE: Ord can be the order of evaluation of precedence (which 'Pretty' printing also accounts for). + deriving (Eq, Ord, Generic, Typeable, Data, Show, NFData) --- 2021-11-09: NOTE: rename OperatorInfo accessors to `get*` --- 2021-08-10: NOTE: --- All this is a sidecar: --- * This type --- * detectPrecedence --- * getUnaryOperation --- * getBinaryOperation --- * getSpecialOperation --- can reduced in favour of adding precedence field into @NOperatorDef@. --- details: https://github.com/haskell-nix/hnix/issues/982 -data OperatorInfo = - OperatorInfo - { precedence :: Int - , associativity :: NAssoc - , operatorName :: Text - } - deriving (Eq, Ord, Generic, Typeable, Data, Show) +-- Supplied since its definition gets called/used frequently. +-- | Functional application operator definition, left associative, high precedence. +appOpDef :: NOperatorDef +appOpDef = NAppDef NAppOp NAssocLeft 1 " " -- This defined as "2" in Nix lang spec. -detectPrecedence - :: Ord a - => ( Int - -> (NOperatorDef, Operator Parser NExprLoc) - -> [(a, OperatorInfo)] - ) - -> a - -> OperatorInfo -detectPrecedence spec = (mapOfOpWithPrecedence Map.!) - where - mapOfOpWithPrecedence = - Map.fromList $ - fold $ - zipWith - (foldMap . spec) - [1 ..] - l +-- 2022-01-26: NOTE: When total - make sure to hide & inline all these instances to get free solution. +-- | Class to get a private free construction to abstract away the gap between the Nix operation types +-- 'NUnaryOp', 'NBinaryOp', 'NSpecialOp'. +-- And in doing remove 'OperatorInfo' from existance. +class NOp a where + {-# minimal getOpDef, getOpAssoc, getOpPrecedence, getOpName #-} + + getOpDef :: a -> NOperatorDef + getOpAssoc :: a -> NAssoc + getOpPrecedence :: a -> NOpPrecedence + getOpName :: a -> NOpName + +instance NOp NAppOp where + getOpDef NAppOp = appOpDef + getOpAssoc _op = fun appOpDef where - l :: [[(NOperatorDef, Operator Parser NExprLoc)]] - l = nixOperators $ fail "unused" + fun (NAppDef _op assoc _prec _name) = assoc + fun _ = error "Impossible happened, funapp operation should been matched." + getOpPrecedence _op = fun appOpDef + where + fun (NAppDef _op _assoc prec _name) = prec + fun _ = error "Impossible happened, funapp operation should been matched." + getOpName _ = fun appOpDef + where + fun (NAppDef _op _assoc _prec name) = name + fun _ = error "Impossible happened, funapp operation should been matched." -getUnaryOperator :: NUnaryOp -> OperatorInfo -getUnaryOperator = detectPrecedence spec - where - spec :: Int -> (NOperatorDef, b) -> [(NUnaryOp, OperatorInfo)] - spec i = +instance NOp NUnaryOp where + getOpDef = \case - (NUnaryDef op name, _) -> one (op, OperatorInfo i NAssocNone name) - _ -> mempty + NNeg -> NUnaryDef NNeg NAssocRight 3 "-" + NNot -> NUnaryDef NNot NAssocRight 8 "!" + getOpAssoc = fun . getOpDef + where + fun (NUnaryDef _op assoc _prec _name) = assoc + fun _ = error "Impossible happened, unary operation should been matched." + getOpPrecedence = fun . getOpDef + where + fun (NUnaryDef _op _assoc prec _name) = prec + fun _ = error "Impossible happened, unary operation should been matched." + getOpName = fun . getOpDef + where + fun (NUnaryDef _op _assoc _prec name) = name + fun _ = error "Impossible happened, unary operation should been matched." -getBinaryOperator :: NBinaryOp -> OperatorInfo -getBinaryOperator = detectPrecedence spec - where - spec :: Int -> (NOperatorDef, b) -> [(NBinaryOp, OperatorInfo)] - spec i = +instance NOp NBinaryOp where + getOpDef = \case - (NBinaryDef assoc op name, _) -> one (op, OperatorInfo i assoc name) - _ -> mempty + NConcat -> NBinaryDef NConcat NAssocRight 5 "++" + NMult -> NBinaryDef NMult NAssocLeft 6 "*" + NDiv -> NBinaryDef NDiv NAssocLeft 6 "/" + NPlus -> NBinaryDef NPlus NAssocLeft 7 "+" + NMinus -> NBinaryDef NMinus NAssocLeft 7 "-" + NUpdate -> NBinaryDef NUpdate NAssocRight 9 "//" + NLt -> NBinaryDef NLt NAssocLeft 10 "<" + NLte -> NBinaryDef NLte NAssocLeft 10 "<=" + NGt -> NBinaryDef NGt NAssocLeft 10 ">" + NGte -> NBinaryDef NGte NAssocLeft 10 ">=" + NEq -> NBinaryDef NEq NAssoc 11 "==" + NNEq -> NBinaryDef NNEq NAssoc 11 "!=" + NAnd -> NBinaryDef NAnd NAssocLeft 12 "&&" + NOr -> NBinaryDef NOr NAssocLeft 13 "||" + NImpl -> NBinaryDef NImpl NAssocRight 14 "->" + getOpAssoc = fun . getOpDef + where + fun (NBinaryDef _op assoc _prec _name) = assoc + fun _ = error "Impossible happened, binary operation should been matched." + getOpPrecedence = fun . getOpDef + where + fun (NBinaryDef _op _assoc prec _name) = prec + fun _ = error "Impossible happened, binary operation should been matched." + getOpName = fun . getOpDef + where + fun (NBinaryDef _op _assoc _prec name) = name + fun _ = error "Impossible happened, binary operation should been matched." -getSpecialOperator :: NSpecialOp -> OperatorInfo -getSpecialOperator NSelectOp = OperatorInfo 1 NAssocLeft "." -getSpecialOperator o = detectPrecedence spec o - where - spec :: Int -> (NOperatorDef, b) -> [(NSpecialOp, OperatorInfo)] - spec i = - \case - (NSpecialDef assoc op name, _) -> one (op, OperatorInfo i assoc name) - _ -> mempty +instance NOp NSpecialOp where + getOpDef = + \case + NSelectOp -> NSpecialDef NSelectOp NAssocLeft 1 "." + NHasAttrOp -> NSpecialDef NHasAttrOp NAssocLeft 4 "?" + NTerm -> NSpecialDef NTerm NAssocLeft 1 "???" + getOpAssoc = fun . getOpDef + where + fun (NSpecialDef _op assoc _prec _name) = assoc + fun _ = error "Impossible happened, special operation should been matched." + getOpPrecedence = fun . getOpDef + where + fun (NSpecialDef _op _assoc prec _name) = prec + fun _ = error "Impossible happened, special operation should been matched." + getOpName = fun . getOpDef + where + fun (NSpecialDef _op _assoc _prec name) = name + fun _ = error "Impossible happened, special operation should been matched." +instance NOp NOperatorDef where + getOpDef op = op + getOpAssoc = \case + (NAppDef _op assoc _prec _name) -> assoc + (NUnaryDef _op assoc _prec _name) -> assoc + (NBinaryDef _op assoc _prec _name) -> assoc + (NSpecialDef _op assoc _prec _name) -> assoc + getOpPrecedence = fun . getOpDef + where + fun (NAppDef _op _assoc prec _name) = prec + fun (NUnaryDef _op _assoc prec _name) = prec + fun (NBinaryDef _op _assoc prec _name) = prec + fun (NSpecialDef _op _assoc prec _name) = prec + getOpName = fun . getOpDef + where + fun (NAppDef _op _assoc _prec name) = name + fun (NUnaryDef _op _assoc _prec name) = name + fun (NBinaryDef _op _assoc _prec name) = name + fun (NSpecialDef _op _assoc _prec name) = name + +prefix :: NUnaryOp -> Operator Parser NExprLoc +prefix op = + Prefix $ manyUnaryOp $ opWithLoc annNUnary op $ getOpName op +-- postfix name op = (NUnaryDef name op, +-- Postfix (opWithLoc annNUnary op name)) + +manyUnaryOp :: MonadPlus f => f (a -> a) -> f (a -> a) +manyUnaryOp f = foldr1 (.) <$> some f + +binary + :: NBinaryOp + -> Operator Parser NExprLoc +binary op = + mapAssocToInfix (getOpAssoc op) $ opWithLoc annNBinary op (getOpName op) + +mapAssocToInfix :: NAssoc -> m (a -> a -> a) -> Operator m a +mapAssocToInfix NAssocLeft = InfixL +mapAssocToInfix NAssoc = InfixN +mapAssocToInfix NAssocRight = InfixR + -- ** x: y lambda function -- | Gets all of the arguments for a function. @@ -686,13 +717,13 @@ try $ do name <- identifier <* symbol '@' - (pset, variadic) <- params + (variadic, pset) <- params pure $ ParamSet (pure name) variadic pset -- Parameters named by an identifier on the right, or none (`{x, y} @ args`) atRight = do - (pset, variadic) <- params + (variadic, pset) <- params name <- optional $ symbol '@' *> identifier pure $ ParamSet name variadic pset @@ -701,18 +732,20 @@ -- Collects the parameters within curly braces. Returns the parameters and -- an flag indication if the parameters are variadic. + getParams :: Parser (Variadic, [(VarName, Maybe NExprLoc)]) getParams = go mempty 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 = ((acc, Variadic) <$ symbols "...") <|> getMore + go :: [(VarName, Maybe NExprLoc)] -> Parser (Variadic, [(VarName, Maybe NExprLoc)]) + go acc = ((Variadic, acc) <$ symbols "...") <|> getMore where - getMore :: Parser ([(VarName, Maybe NExprLoc)], Variadic) + getMore :: Parser (Variadic, [(VarName, Maybe NExprLoc)]) getMore = -- Could be nothing, in which just return what we have so far. - option (acc, mempty) $ + option (mempty, acc) $ do -- Get an argument name and an optional default. pair <- @@ -723,7 +756,7 @@ let args = acc <> one pair -- Either return this, or attempt to get a comma and restart. - option (args, mempty) $ symbol ',' *> go args + option (mempty, args) $ symbol ',' *> go args nixLambda :: Parser NExprLoc nixLambda = @@ -739,14 +772,16 @@ annotateNamedLocation "let block" $ reserved "let" *> (letBody <|> letBinders) where + -- | Expressions `let {..., body = ...}' are just desugared + -- into `(rec {..., body = ...}).body'. + letBody = (\ expr -> NSelect Nothing expr (one $ StaticKey "body")) <$> attrset + where + attrset = annotateLocation $ NSet Recursive <$> braces nixBinders + -- | Regular `let` letBinders = liftA2 NLet nixBinders (exprAfterReservedWord "in") - -- Let expressions `let {..., body = ...}' are just desugared - -- into `(rec {..., body = ...}).body'. - letBody = (\x -> NSelect Nothing x (one $ StaticKey "body")) <$> aset - aset = annotateLocation $ NSet Recursive <$> braces nixBinders -- ** if then else @@ -754,7 +789,7 @@ nixIf = annotateNamedLocation "if" $ liftA3 NIf - (reserved "if" *> nixExprAlgebra) + (reserved "if" *> nixExpr) (exprAfterReservedWord "then") (exprAfterReservedWord "else") @@ -779,8 +814,8 @@ -- ** . - reference (selector) into attr -selDot :: Parser () -selDot = label "." $ try (symbol '.' *> notFollowedBy nixPath) +selectorDot :: Parser () +selectorDot = label "." $ try (symbol '.' *> notFollowedBy nixPath) keyName :: Parser (NKeyName NExprLoc) keyName = dynamicKey <|> staticKey @@ -790,23 +825,20 @@ nixSelector :: Parser (AnnUnit SrcSpan (NAttrPath NExprLoc)) nixSelector = - annotateLocation1 $ - do - (x : xs) <- keyName `sepBy1` selDot - pure $ x :| xs + annotateLocation1 $ fromList <$> keyName `sepBy1` selectorDot nixSelect :: Parser NExprLoc -> Parser NExprLoc nixSelect term = do res <- - liftA2 build + liftA2 builder term (optional $ - liftA2 (,) - (selDot *> nixSelector) + liftA2 (flip (,)) + (selectorDot *> nixSelector) (optional $ reserved "or" *> nixTerm) ) - continues <- optional $ lookAhead selDot + continues <- optional $ lookAhead selectorDot maybe id @@ -814,25 +846,60 @@ continues (pure res) where - build + builder :: NExprLoc -> Maybe - ( AnnUnit SrcSpan (NAttrPath NExprLoc) - , Maybe NExprLoc + ( Maybe NExprLoc + , AnnUnit SrcSpan (NAttrPath NExprLoc) ) -> NExprLoc - build t = + builder t = maybe t - (\ (a, m) -> (`annNSelect` t) m a) + (uncurry (`annNSelect` t)) -- ** _ - syntax hole nixSynHole :: Parser NExprLoc -nixSynHole = annotateLocation $ mkSynHoleF <$> coerce (char '^' *> identifier) +nixSynHole = + annotateLocation $ mkSynHoleF <$> coerce (char '^' *> identifier) +-- List of Nix operation parsers with their precedence. +opParsers :: [(NOpPrecedence, Operator Parser NExprLoc)] +opParsers = + -- This is not parsed here, even though technically it's part of the + -- expression table. The problem is that in some cases, such as list + -- membership, it's also a term. And since terms are effectively the + -- highest precedence entities parsed by the expression parser, it ends up + -- working out that we parse them as a kind of "meta-term". + -- {- 1 -} + -- [ ( NSpecialDef "." NSelectOp NAssocLeft + -- , Postfix $ + -- do + -- sel <- seldot *> selector + -- mor <- optional (reserved "or" *> term) + -- pure $ \x -> annNSelect x sel mor) + -- ] + + -- NApp is left associative + -- 2018-05-07: jwiegley: Thanks to Brent Yorgey for showing me this trick! + specialBuilder NAppOp (InfixL $ annNApp <$ symbols mempty) <> + specialBuilder NHasAttrOp (Postfix $ symbol '?' *> (flip annNHasAttr <$> nixSelector)) <> + builder prefix <> + builder binary + where + specialBuilder :: NOp t => t -> b -> [(NOpPrecedence, b)] + specialBuilder op parser = one (entry op (const parser)) + + builder :: (Enum t, Bounded t, NOp t) => (t -> b) -> [(NOpPrecedence, b)] + builder tp = fmap (`entry` tp) universe + + entry :: NOp t => t -> (t -> b) -> (NOpPrecedence, b) + entry op parser = (getOpPrecedence op, parser op) + + -- ** Expr & its constituents (Language term, expr algebra) nixTerm :: Parser NExprLoc @@ -861,15 +928,19 @@ <> [ nixNull | c == 'n' ] <> one (nixSelect nixSym) +-- | Bundles parsers into @[[]]@ based on precedence (form is required for `megaparsec`). +nixOperators :: [[ Operator Parser NExprLoc ]] +nixOperators = + snd <$> + groupSort opParsers + -- | Nix expression algebra parser. -- "Expression algebra" is to explain @megaparsec@ use of the term "Expression" (parser for language algebraic coperators without any statements (without @let@ etc.)), which is essentially an algebra inside the language. nixExprAlgebra :: Parser NExprLoc nixExprAlgebra = makeExprParser nixTerm - (snd <<$>> - nixOperators nixSelector - ) + nixOperators nixExpr :: Parser NExprLoc nixExpr = keywords <|> nixLambda <|> nixExprAlgebra @@ -881,25 +952,25 @@ type Result a = Either (Doc Void) a -parseFromFileEx :: MonadFile m => Parser a -> Path -> m (Result a) -parseFromFileEx parser file = - do - input <- liftIO $ readFile file - pure $ - either - (Left . pretty . errorBundlePretty) - pure - $ (`evalState` initialPos (coerce file)) $ runParserT parser (coerce file) input - -parseFromText :: Parser a -> Text -> Result a -parseFromText parser input = - let stub = "" in +parseWith + :: Parser a + -> Path + -> Text + -> Either (Doc Void) a +parseWith parser file input = either (Left . pretty . errorBundlePretty) pure - $ (`evalState` initialPos stub) $ (`runParserT` stub) parser input + $ (`evalState` initialPos (coerce file)) $ (`runParserT` coerce file) parser input + +parseFromFileEx :: MonadFile m => Parser a -> Path -> m (Result a) +parseFromFileEx parser file = parseWith parser file <$> readFile file + +parseFromText :: Parser a -> Text -> Result a +parseFromText = (`parseWith` "") + fullContent :: Parser NExprLoc fullContent = whiteSpace *> nixExpr <* eof @@ -927,7 +998,7 @@ parseNixTextLoc = parseNixText' id -parseExpr :: (MonadFail m) => Text -> m NExpr +parseExpr :: MonadFail m => Text -> m NExpr parseExpr = either (fail . show) diff --git a/src/Nix/Pretty.hs b/src/Nix/Pretty.hs --- a/src/Nix/Pretty.hs +++ b/src/Nix/Pretty.hs @@ -39,7 +39,7 @@ -- 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 + , rootOp :: NOperatorDef , wasPath :: Bool -- This is needed so that when a path is used in a selector path -- we can add brackets appropriately } @@ -52,14 +52,15 @@ antiquote :: NixDoc ann -> Doc ann antiquote x = "${" <> getDoc x <> "}" -mkNixDoc :: OperatorInfo -> Doc ann -> NixDoc ann +mkNixDoc :: NOperatorDef -> Doc ann -> NixDoc ann mkNixDoc o d = NixDoc { getDoc = 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 ann -> NixDoc ann -simpleExpr = mkNixDoc $ OperatorInfo minBound NAssocNone "simple expr" +simpleExpr = + mkNixDoc $ NSpecialDef NTerm NAssoc minBound "simple expr" pathExpr :: Doc ann -> NixDoc ann pathExpr d = (simpleExpr d) { wasPath = True } @@ -71,50 +72,51 @@ -- binding). leastPrecedence :: Doc ann -> NixDoc ann leastPrecedence = - mkNixDoc $ OperatorInfo maxBound NAssocNone "least precedence" + mkNixDoc $ NSpecialDef NTerm NAssoc maxBound "least precedence" -appOp :: OperatorInfo -appOp = getBinaryOperator NApp -appOpNonAssoc :: OperatorInfo -appOpNonAssoc = appOp { associativity = NAssocNone } +data WrapMode + = ProcessAllWrap + | PrecedenceWrap + deriving Eq -selectOp :: OperatorInfo -selectOp = getSpecialOperator NSelectOp +needsParens + :: WrapMode + -> NOperatorDef + -> NOperatorDef + -> Bool +needsParens mode host sub = + getOpPrecedence host > getOpPrecedence sub + || bool + False + ( NAssoc /= getOpAssoc host + && on (==) getOpAssoc host sub + && on (==) getOpPrecedence host sub + ) + (ProcessAllWrap == mode) -hasAttrOp :: OperatorInfo -hasAttrOp = getSpecialOperator NHasAttrOp +maybeWrapDoc :: WrapMode -> NOperatorDef -> NixDoc ann -> Doc ann +maybeWrapDoc mode host sub = + bool + parens + id + (needsParens mode host (rootOp sub)) + (getDoc sub) -- | Determine if to return doc wraped into parens, -- according the given operator. -precedenceWrap :: OperatorInfo -> NixDoc ann -> Doc ann -precedenceWrap op subExpr = - maybeWrap $ getDoc subExpr - where - maybeWrap :: Doc ann -> Doc ann - maybeWrap = - bool - parens - id - needsParens - where - needsParens :: Bool - needsParens = - precedence root < precedence op - || ( precedence root == precedence op - && associativity root == associativity op - && associativity op /= NAssocNone - ) - - root = rootOp subExpr +wrap :: NOperatorDef -> NixDoc ann -> Doc ann +wrap = maybeWrapDoc ProcessAllWrap +precedenceWrap :: NOperatorDef -> NixDoc ann -> Doc ann +precedenceWrap = maybeWrapDoc PrecedenceWrap -- Used in the selector case to print a path in a selector as -- "${./abc}" -wrapPath :: OperatorInfo -> NixDoc ann -> Doc ann +wrapPath :: NOperatorDef -> NixDoc ann -> Doc ann wrapPath op sub = bool - (precedenceWrap op sub) + (wrap op sub) (dquotes $ antiquote sub) (wasPath sub) @@ -243,7 +245,7 @@ NConstant atom -> prettyAtom atom NStr str -> simpleExpr $ prettyString str NList xs -> - prettyContainer "[" (precedenceWrap appOpNonAssoc) "]" xs + prettyContainer "[" (precedenceWrap appOpDef) "]" xs NSet NonRecursive xs -> prettyContainer "{" prettyBind "}" xs NSet Recursive xs -> @@ -255,40 +257,49 @@ [ prettyParams args <> ":" , getDoc body ] - NBinary NApp fun arg -> - mkNixDoc appOp (precedenceWrap appOp fun <> " " <> precedenceWrap appOpNonAssoc arg) + NApp fun arg -> + mkNixDoc appOpDef (wrap appOpDef fun <> " " <> precedenceWrap appOpDef arg) NBinary op r1 r2 -> mkNixDoc - opInfo $ + opDef $ hsep - [ f NAssocLeft r1 - , pretty $ operatorName opInfo - , f NAssocRight r2 + [ pickWrapMode NAssocLeft r1 + , pretty @Text $ coerce @NOpName $ getOpName op + , pickWrapMode NAssocRight r2 ] where - opInfo = getBinaryOperator op - f :: NAssoc -> NixDoc ann -> Doc ann - f x = - precedenceWrap - $ bool - opInfo - (opInfo { associativity = NAssocNone }) - (associativity opInfo /= x) + opDef = getOpDef op + + pickWrapMode :: NAssoc -> NixDoc ann -> Doc ann + pickWrapMode x = + bool + wrap + precedenceWrap + (getOpAssoc opDef /= x) + opDef NUnary op r1 -> mkNixDoc - opInfo $ - pretty (operatorName opInfo) <> precedenceWrap opInfo r1 + opDef $ + pretty @Text (coerce $ getOpName op) <> wrap opDef r1 where - opInfo = getUnaryOperator op + opDef = getOpDef op NSelect o r' attr -> maybe (mkNixDoc selectOp) (const leastPrecedence) o - $ wrapPath selectOp (mkNixDoc selectOp (precedenceWrap appOpNonAssoc r')) <> "." <> prettySelector attr <> - ((" or " <>) . precedenceWrap appOpNonAssoc) `whenJust` o + $ wrapPath selectOp (mkNixDoc selectOp (wrap appOpDef r')) <> "." <> prettySelector attr <> + ((" or " <>) . precedenceWrap appOpDef) `whenJust` o + where + selectOp :: NOperatorDef + selectOp = getOpDef NSelectOp + NHasAttr r attr -> - mkNixDoc hasAttrOp (precedenceWrap hasAttrOp r <> " ? " <> prettySelector attr) + mkNixDoc hasAttrOp (wrap hasAttrOp r <> " ? " <> prettySelector attr) + where + hasAttrOp :: NOperatorDef + hasAttrOp = getOpDef NHasAttrOp + NEnvPath p -> simpleExpr $ pretty @String $ "<" <> coerce p <> ">" NLiteralPath p -> pathExpr $ @@ -314,15 +325,14 @@ NIf cond trueBody falseBody -> leastPrecedence $ group $ - nest 2 $ - ifThenElse getDoc + nest 2 ifThenElse where - ifThenElse :: (NixDoc ann -> Doc ann) -> Doc ann - ifThenElse wp = + ifThenElse :: Doc ann + ifThenElse = sep - [ "if " <> wp cond - , align ("then " <> wp trueBody) - , align ("else " <> wp falseBody) + [ "if " <> getDoc cond + , align $ "then " <> getDoc trueBody + , align $ "else " <> getDoc falseBody ] NWith scope body -> prettyAddScope "with " scope body @@ -331,9 +341,9 @@ NSynHole name -> simpleExpr $ pretty @Text ("^" <> coerce name) where prettyContainer h f t c = - list + handlePresence (simpleExpr (h <> t)) - (const $ simpleExpr $ group $ nest 2 $ vsep $ one h <> (f <$> c) <> one t) + (const $ simpleExpr $ group $ nest 2 (h <> line <> vsep (f <$> c)) <> line <> t) c prettyAddScope h c b = @@ -380,7 +390,7 @@ -> NValue t f m -> Doc ann prettyProv wasThunk v = - list + handlePresence id (\ ps pv -> fillSep diff --git a/src/Nix/Reduce.hs b/src/Nix/Reduce.hs --- a/src/Nix/Reduce.hs +++ b/src/Nix/Reduce.hs @@ -22,7 +22,7 @@ import Nix.Prelude import Control.Monad.Catch ( MonadCatch(catch) ) -#if !MIN_VERSION_base(4,13,0) +#if !MIN_VERSION_base(4,12,0) import Prelude hiding ( fail ) import Control.Monad.Fail #endif @@ -102,7 +102,7 @@ (\ err -> fail $ "Parse failed: " <> show err) (\ x -> do let - pos = join (SourcePos "Reduce.hs") $ mkPos 1 + pos = join (NSourcePos "Reduce.hs") $ (coerce . mkPos) 1 span = join SrcSpan pos cur = NamedVar @@ -171,13 +171,13 @@ -- -- * Reduce a lambda function by adding its name to the local -- scope and recursively reducing its body. -reduce (NBinaryAnnF bann NApp fun arg) = +reduce (NAppAnnF bann fun arg) = (\case f@(NSymAnn _ "import") -> (\case -- NEnvPathAnn pann origPath -> staticImport pann origPath NLiteralPathAnn pann origPath -> staticImport pann origPath - v -> pure $ NBinaryAnn bann NApp f v + v -> pure $ NAppAnn bann f v ) =<< arg NAbsAnn _ (Param name) body -> @@ -187,7 +187,7 @@ (coerce $ HM.singleton name x) (foldFix reduce body) - f -> NBinaryAnn bann NApp f <$> arg + f -> NAppAnn bann f <$> arg ) =<< fun -- | Reduce an integer addition to its result. @@ -383,7 +383,7 @@ NLet binds (Just body@(Ann _ x)) -> pure $ - list + handlePresence x (`NLet` body) (mapMaybe pruneBinding binds) @@ -391,13 +391,13 @@ NSelect alt (Just aset) attr -> pure $ NSelect (join alt) aset $ pruneKeyName <$> attr + -- If the function was never called, it means its argument was in a + -- thunk that was forced elsewhere. + NApp Nothing (Just _) -> Nothing + -- These are the only short-circuiting binary operators NBinary NAnd (Just (Ann _ larg)) _ -> pure larg NBinary NOr (Just (Ann _ larg)) _ -> pure larg - - -- If the function was never called, it means its argument was in a - -- thunk that was forced elsewhere. - NBinary NApp Nothing (Just _) -> Nothing -- The idea behind emitted a binary operator where one side may be -- invalid is that we're trying to emit what will reproduce whatever diff --git a/src/Nix/Render.hs b/src/Nix/Render.hs --- a/src/Nix/Render.hs +++ b/src/Nix/Render.hs @@ -2,7 +2,6 @@ {-# language CPP #-} {-# language ConstraintKinds #-} {-# language DefaultSignatures #-} -{-# language GADTs #-} {-# language TypeFamilies #-} {-# language TypeOperators #-} {-# language MultiWayIf #-} @@ -14,6 +13,9 @@ import Nix.Utils.Fix1 ( Fix1T , MonadFix1T ) +import Nix.Expr.Types ( NPos(..) + , NSourcePos(..) + ) import Nix.Expr.Types.Annotated import Prettyprinter import qualified System.Directory as S @@ -65,14 +67,14 @@ instance (MonadFix1T t m, MonadIO (Fix1T t m), MonadFail (Fix1T t m), MonadFile m) => MonadFile (Fix1T t m) -posAndMsg :: SourcePos -> Doc a -> ParseError s Void -posAndMsg (SourcePos _ lineNo _) msg = +posAndMsg :: NSourcePos -> Doc a -> ParseError s Void +posAndMsg (NSourcePos _ (coerce -> lineNo) _) msg = FancyError (unPos lineNo) (Set.fromList $ one (ErrorFail (show msg) :: ErrorFancy Void)) renderLocation :: MonadFile m => SrcSpan -> Doc a -> m (Doc a) -renderLocation (SrcSpan (SourcePos (coerce -> file) begLine begCol) (SourcePos (coerce -> file') endLine endCol)) msg +renderLocation (SrcSpan (NSourcePos file (coerce -> begLine) (coerce -> begCol)) (NSourcePos file' (coerce -> endLine) (coerce -> endCol))) msg | file == file' && file == "" && begLine == endLine = pure $ "In raw input string at position " <> pretty (unPos begCol) diff --git a/src/Nix/Render/Frame.hs b/src/Nix/Render/Frame.hs --- a/src/Nix/Render/Frame.hs +++ b/src/Nix/Render/Frame.hs @@ -2,7 +2,6 @@ {-# language AllowAmbiguousTypes #-} {-# language ConstraintKinds #-} {-# language MultiWayIf #-} -{-# language GADTs #-} {-# language TypeFamilies #-} @@ -50,7 +49,11 @@ -- 2021-10-22: NOTE: List reverse is completely conterproductive. `reverse` of list famously neest to traverse the whole list to take the last element | verbosity <= Informational -> (foldMap renderPosition (reverse xs) <>) <$> render1 x | otherwise -> foldMapM render1 (reverse xss) - pure $ list mempty vsep renderedFrames + pure $ + handlePresence + mempty + vsep + renderedFrames where render1 :: NixFrame -> m [Doc ann1] render1 = renderFrame @v @t @f @@ -58,14 +61,14 @@ renderPosition :: NixFrame -> [Doc ann] renderPosition = whenJust - (\ pos -> one ("While evaluating at " <> pretty (sourcePosPretty pos) <> colon)) + (\ pos -> one ("While evaluating at " <> pretty (sourcePosPretty $ toSourcePos pos) <> colon)) . framePos @v @m framePos :: forall v (m :: Type -> Type) . (Typeable m, Typeable v) => NixFrame - -> Maybe SourcePos + -> Maybe NSourcePos framePos (NixFrame _ f) = (\case EvaluatingExpr _ (Ann (SrcSpan beg _) _) -> pure beg diff --git a/src/Nix/Standard.hs b/src/Nix/Standard.hs --- a/src/Nix/Standard.hs +++ b/src/Nix/Standard.hs @@ -19,7 +19,7 @@ import Control.Monad.Fail ( MonadFail ) #endif import Control.Monad.Free ( Free(Free) ) -import Control.Monad.Reader ( MonadFix ) +import Control.Monad.Fix ( MonadFix ) import Control.Monad.Ref ( MonadRef(newRef) , MonadAtomicRef ) @@ -47,14 +47,9 @@ StdCited (Cited (StdThunk m) (StdCited m) m a) deriving - ( Generic - , Typeable - , Functor - , Applicative - , Foldable - , Traversable - , Comonad - , ComonadEnv [Provenance m (StdValue m)] + ( Generic, Typeable + , Functor, Applicative, Comonad, ComonadEnv [Provenance m (StdValue m)] + , Foldable, Traversable ) newtype StdThunk m = @@ -172,6 +167,8 @@ -- * @instance MonadThunkF@ (Kleisli functor HOFs) + +-- | This is a functorized version in CPS. -- Please do not use MonadThunkF instances to define MonadThunk. as MonadThunk uses specialized functions. instance diff --git a/src/Nix/String.hs b/src/Nix/String.hs --- a/src/Nix/String.hs +++ b/src/Nix/String.hs @@ -143,7 +143,7 @@ -- | Returns True if the NixString has an associated context hasContext :: NixString -> Bool -hasContext (NixString c _) = not $ null c +hasContext (NixString c _) = isPresent c -- ** Getters @@ -183,7 +183,7 @@ mkLstCtxFor DirectPath cv { nlcvPath = False } NixLikeContextValue _ True _ -> mkLstCtxFor AllOutputs cv { nlcvAllOutputs = False } - NixLikeContextValue _ _ ls | not (null ls) -> + NixLikeContextValue _ _ ls | isPresent ls -> mkCtxFor . DerivationOutput <$> ls _ -> mempty where @@ -211,8 +211,8 @@ stringContext where fun :: (StringContext -> AttrSet NixLikeContextValue -> AttrSet NixLikeContextValue) - fun sc hm = - uncurry (M.insertWith (<>)) (swap $ toNixLikeContextValue sc) hm + fun sc = + uncurry (M.insertWith (<>)) (swap $ toNixLikeContextValue sc) -- | Add 'StringContext's into the resulting set. addStringContext diff --git a/src/Nix/TH.hs b/src/Nix/TH.hs --- a/src/Nix/TH.hs +++ b/src/Nix/TH.hs @@ -1,72 +1,92 @@ -{-# language QuasiQuotes #-} -{-# language TemplateHaskell #-} - -{-# options_ghc -Wno-missing-fields #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-missing-fields #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} module Nix.TH where -import Nix.Prelude +import Data.Fix ( Fix(Fix) ) import Data.Generics.Aliases ( extQ ) import qualified Data.Set as Set import Language.Haskell.TH -import qualified Language.Haskell.TH.Syntax as TH import Language.Haskell.TH.Quote import Nix.Atoms import Nix.Expr.Types import Nix.Expr.Types.Annotated import Nix.Parser +import Nix.Prelude +removeMissingNames :: Set VarName -> Q (Set VarName) +removeMissingNames = + fmap Set.fromAscList + . filterM (fmap isJust . lookupValueName . toString) + . Set.toAscList + quoteExprExp :: String -> ExpQ -quoteExprExp s = - do - expr <- parseExpr $ fromString s - dataToExpQ - (extQOnFreeVars metaExp expr `extQ` (pure . (TH.lift :: Text -> ExpQ))) - expr +quoteExprExp s = do + expr <- parseExpr $ fromString s + vars <- removeMissingNames $ getFreeVars expr + dataToExpQ (extQOnFreeVars metaExp vars) expr quoteExprPat :: String -> PatQ -quoteExprPat s = - do - expr <- parseExpr @Q $ fromString s - dataToPatQ - (extQOnFreeVars @_ @NExprLoc @PatQ metaPat expr) - expr - +quoteExprPat s = do + expr <- parseExpr @Q $ fromString s + vars <- removeMissingNames $ getFreeVars expr + dataToPatQ (extQOnFreeVars @_ @NExprLoc @PatQ metaPat vars) expr -- | Helper function. extQOnFreeVars - :: ( Typeable b - , Typeable loc - ) - => ( Set VarName - -> loc - -> Maybe q - ) - -> NExpr + :: (Typeable b, Typeable loc) + => (Set VarName -> loc -> Maybe q) + -> Set VarName -> b -> Maybe q -extQOnFreeVars f = extQ (const Nothing) . f . getFreeVars +extQOnFreeVars f = extQ (const Nothing) . f class ToExpr a where - toExpr :: a -> NExprLoc + toExpr :: a -> NExpr -instance ToExpr NExprLoc where +instance ToExpr NExpr where toExpr = id instance ToExpr VarName where - toExpr = NSymAnn nullSpan + toExpr = Fix . NSym +instance {-# OVERLAPPING #-} ToExpr String where + toExpr = Fix . NStr . fromString + +instance ToExpr Text where + toExpr = toExpr . toString + instance ToExpr Int where - toExpr = NConstantAnn nullSpan . NInt . fromIntegral + toExpr = Fix . NConstant . NInt . fromIntegral +instance ToExpr Bool where + toExpr = Fix . NConstant . NBool + instance ToExpr Integer where - toExpr = NConstantAnn nullSpan . NInt + toExpr = Fix . NConstant . NInt instance ToExpr Float where - toExpr = NConstantAnn nullSpan . NFloat + toExpr = Fix . NConstant . NFloat -metaExp :: Set VarName -> NExprLoc -> Maybe ExpQ -metaExp fvs (NSymAnn _ x) | x `Set.member` fvs = +instance (ToExpr a) => ToExpr [a] where + toExpr = Fix . NList . fmap toExpr + +instance (ToExpr a) => ToExpr (NonEmpty a) where + toExpr = toExpr . toList + +instance ToExpr () where + toExpr () = Fix $ NConstant NNull + +instance (ToExpr a) => ToExpr (Maybe a) where + toExpr = maybe (toExpr ()) toExpr + +instance (ToExpr a, ToExpr b) => ToExpr (Either a b) where + toExpr = either toExpr toExpr + +metaExp :: Set VarName -> NExpr -> Maybe ExpQ +metaExp fvs (Fix (NSym x)) | x `Set.member` fvs = pure [| toExpr $(varE (mkName $ toString x)) |] metaExp _ _ = Nothing diff --git a/src/Nix/Thunk.hs b/src/Nix/Thunk.hs --- a/src/Nix/Thunk.hs +++ b/src/Nix/Thunk.hs @@ -1,6 +1,7 @@ {-# language DefaultSignatures #-} {-# language FunctionalDependencies #-} {-# language TypeFamilies #-} +{-# language TypeOperators #-} module Nix.Thunk where diff --git a/src/Nix/Type/Infer.hs b/src/Nix/Type/Infer.hs --- a/src/Nix/Type/Infer.hs +++ b/src/Nix/Type/Infer.hs @@ -26,8 +26,8 @@ , MonadCatch(..) ) import Control.Monad.Except ( MonadError(throwError,catchError) ) -import Control.Monad.Logic hiding ( fail ) -import Control.Monad.Reader ( MonadFix ) +import Control.Monad.Logic +import Control.Monad.Fix ( MonadFix ) import Control.Monad.Ref ( MonadAtomicRef(..) , MonadRef(..) ) @@ -635,8 +635,8 @@ (Set.difference `on` Set.fromList) (Assumption.keys as ) ( Env.keys env) - unless - (Set.null unbounds) + when + (isPresent unbounds) $ typeError $ UnboundVariables $ ordNub $ Set.toList unbounds inferState <- get @@ -677,9 +677,8 @@ binops :: Type -> NBinaryOp -> [Constraint] binops u1 op = if - -- NApp in fact is handled separately -- Equality tells nothing about the types, because any two types are allowed. - | op `elem` [ NApp , NEq , NNEq ] -> mempty + | op `elem` [ NEq , NNEq ] -> mempty | op `elem` [ NGt , NGte , NLt , NLte ] -> inequality | op `elem` [ NAnd , NOr , NImpl ] -> gate | op == NConcat -> concatenation @@ -765,9 +764,10 @@ where report :: [a] -> [TypeError] -> Either [TypeError] [a] report xs e = - if null xs - then Left (ordNub e) - else pure xs + handlePresence + (Left $ ordNub e) + pure + xs -- ** Instances @@ -829,7 +829,7 @@ solvable (EqConst{} , _) = True solvable (ExpInstConst{}, _) = True solvable (ImpInstConst _t1 ms t2, cs) = - Set.null $ (ms `Set.difference` ftv t2) `Set.intersection` atv cs + null $ (ms `Set.difference` ftv t2) `Set.intersection` atv cs solve :: forall m . MonadState InferState m => [Constraint] -> Solver m Subst solve [] = stub diff --git a/src/Nix/Utils.hs b/src/Nix/Utils.hs --- a/src/Nix/Utils.hs +++ b/src/Nix/Utils.hs @@ -19,8 +19,9 @@ , whenTrue , whenFalse , whenJust + , isPresent + , handlePresence , whenText - , list , free , Path(..) @@ -67,13 +68,13 @@ import Data.Binary ( Binary ) import Data.Data ( Data ) import Codec.Serialise ( Serialise ) +import Control.Monad ( foldM ) import Control.Monad.Fix ( MonadFix(..) ) import Control.Monad.Free ( Free(..) ) import Control.Monad.Trans.Control ( MonadTransControl(..) ) import qualified Data.Aeson as A import Data.Fix ( Fix(..) ) import qualified Data.Text as Text -import qualified Data.Text.IO as Text import Lens.Family2 as X ( view , over @@ -84,7 +85,6 @@ , _2 ) import qualified System.FilePath as FilePath -import Control.Monad.List (foldM) #if ENABLE_TRACING import qualified Relude.Debug as X @@ -207,24 +207,27 @@ mempty {-# inline whenJust #-} --- | Analog for @bool@ or @maybe@, for list-like cons structures. -list - :: Foldable t - => b -> (t a -> b) -> t a -> b -list e f l = +isPresent :: Foldable t => t a -> Bool +isPresent = not . null +{-# inline isPresent #-} + + +-- | 'maybe'-like eliminator, for foldable empty/inhabited structures. +handlePresence :: Foldable t => b -> (t a -> b) -> t a -> b +handlePresence d f t = bool - (f l) - e - (null l) -{-# inline list #-} + d + (f t) + (isPresent t) +{-# inline handlePresence #-} whenText :: a -> (Text -> a) -> Text -> a whenText e f t = bool - (f t) e - (Text.null t) + (f t) + (not $ Text.null t) -- | Lambda analog of @maybe@ or @either@ for Free monad. free :: (a -> b) -> (f (Free f a) -> b) -> Free f a -> b @@ -306,8 +309,8 @@ replaceExtension = coerce FilePath.replaceExtension -- | 'Path's 'FilePath.readFile'. -readFile :: Path -> IO Text -readFile = Text.readFile . coerce +readFile :: MonadIO m => Path -> m Text +readFile = fmap decodeUtf8 . readFileBS . coerce -- * Recursion scheme diff --git a/src/Nix/Utils/Fix1.hs b/src/Nix/Utils/Fix1.hs --- a/src/Nix/Utils/Fix1.hs +++ b/src/Nix/Utils/Fix1.hs @@ -5,7 +5,12 @@ {-# language PolyKinds #-} {-# language UndecidableInstances #-} -module Nix.Utils.Fix1 where +module Nix.Utils.Fix1 + ( Fix1(..) + , Fix1T(..) + , MonadFix1T + ) +where import Nix.Prelude import Control.Monad.Fix ( MonadFix ) @@ -22,6 +27,7 @@ -- https://gist.github.com/gmalecha/ceb3778b9fdaa4374976e325ac8feced newtype Fix1 (t :: (k -> Type) -> k -> Type) (a :: k) = Fix1 { unFix1 :: t (Fix1 t) a } +deriving instance Generic (Fix1 t a) deriving instance Functor (t (Fix1 t)) => Functor (Fix1 t) deriving instance Applicative (t (Fix1 t)) @@ -49,6 +55,7 @@ newtype Fix1T (t :: (k -> Type) -> (Type -> Type) -> k -> Type) (m :: Type -> Type) (a :: k) = Fix1T { unFix1T :: t (Fix1T t m) m a } +deriving instance Generic (Fix1T t m m) deriving instance Functor (t (Fix1T t m) m) => Functor (Fix1T t m) deriving instance Applicative (t (Fix1T t m) m) @@ -95,7 +102,6 @@ writeRef r = lift . writeRef r {-# inline writeRef #-} - instance ( MonadFix1T t m , MonadAtomicRef m @@ -109,8 +115,10 @@ newtype Flip (f :: i -> j -> *) (a :: j) (b :: i) = Flip { unFlip :: f b a } --- | Natural Transformations (Included from --- [compdata](https://hackage.haskell.org/package/compdata)) +-- | Natural Transformations +-- ( Included from +-- [compdata](https://hackage.haskell.org/package/compdata) +-- ) type (:->) f g = forall a. f a -> g a class HFunctor f where diff --git a/src/Nix/Value.hs b/src/Nix/Value.hs --- a/src/Nix/Value.hs +++ b/src/Nix/Value.hs @@ -27,7 +27,6 @@ , liftShowsPrec , showsUnaryWith , Eq1(liftEq) ) -import Data.Eq.Deriving import qualified Text.Show import Text.Show ( showsPrec , showString @@ -140,6 +139,16 @@ deriving (Generic, Typeable, Functor) +-- ** Eq + +instance Eq r => Eq (NValueF p m r) where + (==) (NVConstantF x) (NVConstantF y) = x == y + (==) (NVStrF x) (NVStrF y) = x == y + (==) (NVPathF x) (NVPathF y) = x == y + (==) (NVListF x) (NVListF y) = x == y + (==) (NVSetF _ x) (NVSetF _ y) = x == y + (==) _ _ = False + -- ** Eq1 instance Eq1 (NValueF p m) where @@ -266,6 +275,12 @@ -- * @__NValue'__@: forming the (F(A)) +-- | NVConstraint constraint the f layer in @NValue'@. +-- It makes bijection between sub category of Hask and Nix Value possible. +-- 'Comonad' enable Nix Value to Hask part. +-- 'Applicative' enable Hask to Nix Value part. +type NVConstraint f = (Comonad f, Applicative f) + -- | At the time of constructor, the expected arguments to closures are values -- that may contain thunks. The type of such thunks are fixed at that time. newtype NValue' t f m a = @@ -276,13 +291,13 @@ } deriving (Generic, Typeable, Functor, Foldable) -instance (Comonad f, Show a) => Show (NValue' t f m a) where +instance (NVConstraint f, Show a) => Show (NValue' t f m a) where show (NValue' (extract -> v)) = show v -- ** Show1 -instance Comonad f => Show1 (NValue' t f m) where +instance NVConstraint f => Show1 (NValue' t f m) where liftShowsPrec sp sl p = \case NVConstant' atom -> showsUnaryWith showsPrec "NVConstantF" p atom NVStr' ns -> showsUnaryWith showsPrec "NVStrF" p $ ignoreContext ns @@ -378,10 +393,9 @@ -- ** Bijective Hask subcategory <-> @NValue'@ --- *** @F: Hask subcategory → NValue'@ --- +-- *** @F: Hask subcategory <-> NValue'@ -- #mantra# --- $Methods @F: Hask → NValue'@ +-- $Patterns @F: Hask <-> NValue'@ -- -- Since Haskell and Nix are both recursive purely functional lazy languages. -- And since recursion-schemes. @@ -396,87 +410,56 @@ -- Since it is a proper way of scientific implementation, we would eventually form a -- lawful functor. -- --- Facts of which are seen below: +-- Module pattens use @language PatternSynonyms@: bidirectional synonyms (@<-@), +-- and @ViewPatterns@: (@->@) at the same time. +-- @ViewPatterns Control.Comonad.extract@ extracts +-- from the @NValue (Free (NValueF a))@ +-- the @NValueF a@. Which is @NValueF p m r@. Since it extracted from the +-- @NValue@, which is formed by \( (F a -> a) F a \) in the first place. +-- So @NValueF p m r@ which is extracted here, internally holds the next NValue. +-- +-- Facts of bijection between Hask subcategory objects and Nix objects, +-- and between Hask subcategory morphisms and Nix morphisms are seen blow: --- | Haskell constant to the Nix constant, -mkNVConstant' :: Applicative f - => NAtom - -> NValue' t f m r -mkNVConstant' = NValue' . pure . NVConstantF - -- | Using of Nulls is generally discouraged (in programming language design et al.), but, if you need it. -nvNull' :: Applicative f - => NValue' t f m r -nvNull' = mkNVConstant' NNull +pattern NVNull' :: NVConstraint w => NValue' t w m a +pattern NVNull' = NVConstant' NNull +-- | Haskell constant to the Nix constant, +pattern NVConstant' :: NVConstraint w => NAtom -> NValue' t w m a +pattern NVConstant' x <- NValue' (extract -> NVConstantF x) + where NVConstant' = NValue' . pure . NVConstantF -- | Haskell text & context to the Nix text & context, -mkNVStr' :: Applicative f - => NixString - -> NValue' t f m r -mkNVStr' = NValue' . pure . NVStrF - +pattern NVStr' :: NVConstraint w => NixString -> NValue' t w m a +pattern NVStr' ns <- NValue' (extract -> NVStrF ns) + where NVStr' = NValue' . pure . NVStrF -- | Haskell @Path@ to the Nix path, -mkNVPath' :: Applicative f - => Path - -> NValue' t f m r -mkNVPath' = NValue' . pure . NVPathF . coerce - +pattern NVPath' :: NVConstraint w => Path -> NValue' t w m a +pattern NVPath' x <- NValue' (extract -> NVPathF x) + where NVPath' = NValue' . pure . NVPathF . coerce -- | Haskell @[]@ to the Nix @[]@, -mkNVList' :: Applicative f - => [r] - -> NValue' t f m r -mkNVList' = NValue' . pure . NVListF - +pattern NVList' :: NVConstraint w => [a] -> NValue' t w m a +pattern NVList' l <- NValue' (extract -> NVListF l) + where NVList' = NValue' . pure . NVListF -- | Haskell key-value to the Nix key-value, -mkNVSet' :: Applicative f - => PositionSet - -> AttrSet r - -> NValue' t f m r -mkNVSet' p s = NValue' $ pure $ NVSetF p s - +pattern NVSet' :: NVConstraint w => PositionSet -> AttrSet a -> NValue' t w m a +pattern NVSet' p s <- NValue' (extract -> NVSetF p s) + where NVSet' p s = NValue' $ pure $ NVSetF p s -- | Haskell closure to the Nix closure, -mkNVClosure' :: (Applicative f, Functor m) - => Params () - -> (NValue t f m - -> m r - ) - -> NValue' t f m r -mkNVClosure' x f = NValue' $ pure $ NVClosureF x f - +pattern NVClosure' :: NVConstraint w => Params () -> (NValue t w m -> m a) -> NValue' t w m a +pattern NVClosure' x f <- NValue' (extract -> NVClosureF x f) + where NVClosure' x f = NValue' $ pure $ NVClosureF x f -- | Haskell functions to the Nix functions! -mkNVBuiltin' :: (Applicative f, Functor m) - => VarName - -> (NValue t f m -> m r) - -> NValue' t f m r -mkNVBuiltin' name f = NValue' $ pure $ NVBuiltinF name f - - --- So above we have maps of Hask subcategory objects to Nix objects, --- and Hask subcategory morphisms to Nix morphisms. - --- *** @F: NValue -> NValue'@ - --- | Module pattens use @language PatternSynonyms@: unidirectional synonyms (@<-@), --- and @ViewPatterns@: (@->@) at the same time. --- @ViewPatterns Control.Comonad.extract@ extracts --- from the @NValue (Free (NValueF a))@ --- the @NValueF a@. Which is @NValueF p m r@. Since it extracted from the --- @NValue@, which is formed by \( (F a -> a) F a \) in the first place. --- So @NValueF p m r@ which is extracted here, internally holds the next NValue. -pattern NVConstant' x <- NValue' (extract -> NVConstantF x) -pattern NVStr' ns <- NValue' (extract -> NVStrF ns) -pattern NVPath' x <- NValue' (extract -> NVPathF x) -pattern NVList' l <- NValue' (extract -> NVListF l) -pattern NVSet' p s <- NValue' (extract -> NVSetF p s) -pattern NVClosure' x f <- NValue' (extract -> NVClosureF x f) +pattern NVBuiltin' :: NVConstraint w => VarName -> (NValue t w m -> m a) -> NValue' t w m a pattern NVBuiltin' name f <- NValue' (extract -> NVBuiltinF name f) + where NVBuiltin' name f = NValue' $ pure $ NVBuiltinF name f {-# complete NVConstant', NVStr', NVPath', NVList', NVSet', NVClosure', NVBuiltin' #-} @@ -554,7 +537,7 @@ => (forall x . u m x -> m x) -> NValue t f m -> NValue t f (u m) -liftNValue = (`hoistNValue` lift) +liftNValue f = hoistNValue f lift -- *** MonadTransUnlift @@ -574,72 +557,12 @@ -- The morphisms of the functor @Hask → NValue@. -- Continuation of the mantra: "Nix.Value#mantra" - --- | Life of a Haskell thunk to the life of a Nix thunk, -mkNVThunk :: Applicative f - => t - -> NValue t f m -mkNVThunk = Pure - - --- | Life of a Haskell constant to the life of a Nix constant, -mkNVConstant :: Applicative f - => NAtom - -> NValue t f m -mkNVConstant = Free . mkNVConstant' - -- | Using of Nulls is generally discouraged (in programming language design et al.), but, if you need it. -nvNull :: Applicative f - => NValue t f m -nvNull = mkNVConstant NNull --- | Life of a Haskell sting & context to the life of a Nix string & context, -mkNVStr :: Applicative f - => NixString - -> NValue t f m -mkNVStr = Free . mkNVStr' - -mkNVStrWithoutContext :: Applicative f +mkNVStrWithoutContext :: NVConstraint f => Text -> NValue t f m -mkNVStrWithoutContext = mkNVStr . mkNixStringWithoutContext - - --- | Life of a Haskell FilePath to the life of a Nix path -mkNVPath :: Applicative f - => Path - -> NValue t f m -mkNVPath = Free . mkNVPath' - - -mkNVList :: Applicative f - => [NValue t f m] - -> NValue t f m -mkNVList = Free . mkNVList' - - -mkNVSet :: Applicative f - => PositionSet - -> AttrSet (NValue t f m) - -> NValue t f m -mkNVSet p s = Free $ mkNVSet' p s - -mkNVClosure :: (Applicative f, Functor m) - => Params () - -> (NValue t f m - -> m (NValue t f m) - ) - -> NValue t f m -mkNVClosure x f = Free $ mkNVClosure' x f - - -mkNVBuiltin :: (Applicative f, Functor m) - => VarName - -> (NValue t f m - -> m (NValue t f m) - ) - -> NValue t f m -mkNVBuiltin name f = Free $ mkNVBuiltin' name f +mkNVStrWithoutContext = NVStr . mkNixStringWithoutContext builtin @@ -650,7 +573,7 @@ -> m (NValue t f m) ) -- ^ unary function -> m (NValue t f m) -builtin = (pure .) . mkNVBuiltin +builtin = (pure .) . NVBuiltin builtin2 @@ -680,20 +603,22 @@ -- *** @F: Evaluation -> NValue@ -pattern NVThunk t <- Pure t -pattern NVValue v <- Free v -{-# complete NVThunk, NVValue #-} -pattern NVConstant x <- Free (NVConstant' x) -pattern NVStr ns <- Free (NVStr' ns) -pattern NVPath x <- Free (NVPath' x) -pattern NVList l <- Free (NVList' l) -pattern NVSet s x <- Free (NVSet' s x) -pattern NVClosure x f <- Free (NVClosure' x f) -pattern NVBuiltin name f <- Free (NVBuiltin' name f) +pattern NVNull = Free NVNull' +pattern NVThunk t = Pure t +pattern NVValue v = Free v +{-# complete NVThunk, NVValue, NVNull #-} +pattern NVConstant x = Free (NVConstant' x) +pattern NVStr ns = Free (NVStr' ns) +pattern NVPath x = Free (NVPath' x) +pattern NVList l = Free (NVList' l) +pattern NVSet s x = Free (NVSet' s x) +pattern NVBuiltin name f = Free (NVBuiltin' name f) +pattern NVClosure x f = Free (NVClosure' x f) {-# complete NVThunk, NVConstant, NVStr, NVPath, NVList, NVSet, NVClosure, NVBuiltin #-} + -- * @TStringContext@ data TStringContext = NoContext | HasContext @@ -784,7 +709,7 @@ | Expectation ValueType (NValue t f m) deriving Typeable -deriving instance (Comonad f, Show t) => Show (ValueFrame t f m) +deriving instance (NVConstraint f, Show t) => Show (ValueFrame t f m) -- * @MonadDataContext@ @@ -799,10 +724,17 @@ instance MonadDataErrorContext t f m => Exception (ValueFrame t f m) + +-- * @instance Eq NValue'@ + +instance (Eq a, Comonad f) => Eq (NValue' t f m a) where + (==) (NValue' (extract -> x)) (NValue' (extract -> y)) = x == y + -- * @instance Eq1 NValue'@ -- TH derivable works only after MonadDataContext -$(deriveEq1 ''NValue') +instance Comonad f => Eq1 (NValue' t f m) where + liftEq eq (NValue' (extract -> x)) (NValue' (extract -> y)) = liftEq eq x y -- * @NValueF@ traversals, getter & setters diff --git a/src/Nix/Value/Equal.hs b/src/Nix/Value/Equal.hs --- a/src/Nix/Value/Equal.hs +++ b/src/Nix/Value/Equal.hs @@ -31,9 +31,9 @@ -> m () checkComparable x y = case (x, y) of - (NVConstant (NFloat _), NVConstant (NInt _)) -> stub - (NVConstant (NInt _), NVConstant (NFloat _)) -> stub (NVConstant (NInt _), NVConstant (NInt _)) -> stub + (NVConstant (NInt _), NVConstant (NFloat _)) -> stub + (NVConstant (NFloat _), NVConstant (NInt _)) -> stub (NVConstant (NFloat _), NVConstant (NFloat _)) -> stub (NVStr _ , NVStr _ ) -> stub (NVPath _ , NVPath _ ) -> stub @@ -62,7 +62,8 @@ (Data.Semialign.align fa fb) alignEq :: (Align f, Traversable f) => (a -> b -> Bool) -> f a -> f b -> Bool -alignEq eq fa fb = runIdentity $ alignEqM ((Identity .) . eq) fa fb +alignEq eq fa fb = + runIdentity $ alignEqM ((Identity .) . eq) fa fb isDerivationM :: Monad m @@ -73,18 +74,14 @@ -> m Bool isDerivationM f m = maybe - (pure False) - p - (HashMap.Lazy.lookup "type" m) - where - p t = - maybe - -- We should probably really make sure the context is empty here - -- but the C++ implementation ignores it. - False - ((==) "derivation" . ignoreContext) - <$> f t + False + -- (2019-03-18): + -- We should probably really make sure the context is empty here + -- but the C++ implementation ignores it. + ((==) "derivation" . ignoreContext) + . join <$> traverse f (HashMap.Lazy.lookup "type" m) + isDerivation :: Monad m => ( t @@ -141,21 +138,14 @@ -> AttrSet t -> m Bool compareAttrSetsM f eq lm rm = - do - l <- isDerivationM f lm - bool - compareAttrs - (do - r <- isDerivationM f rm - case r of - True - | Just lp <- HashMap.Lazy.lookup "outPath" lm, - Just rp <- HashMap.Lazy.lookup "outPath" rm -> eq lp rp - _ -> compareAttrs - ) - l + bool + compareAttrs + (fromMaybe compareAttrs equalOutPaths) + =<< areDerivations where - compareAttrs = alignEqM eq lm rm + areDerivations = on (liftA2 (&&)) (isDerivationM f ) lm rm + equalOutPaths = on (liftA2 eq) (HashMap.Lazy.lookup "outPath") lm rm + compareAttrs = alignEqM eq lm rm compareAttrSets :: (t -> Maybe NixString) @@ -163,11 +153,12 @@ -> AttrSet t -> AttrSet t -> Bool -compareAttrSets f eq lm rm = runIdentity - $ compareAttrSetsM (Identity . f) ((Identity .) . eq) lm rm +compareAttrSets f eq lm rm = + runIdentity $ compareAttrSetsM (Identity . f) ((Identity .) . eq) lm rm valueEqM - :: (MonadThunk t m (NValue t f m), Comonad f) + :: forall t f m + . (MonadThunk t m (NValue t f m), NVConstraint f) => NValue t f m -> NValue t f m -> m Bool @@ -176,12 +167,13 @@ valueEqM x@(Free _) ( Pure y) = (`thunkEqM` y) =<< thunk (pure x) valueEqM (Free (NValue' (extract -> x))) (Free (NValue' (extract -> y))) = valueFEqM - (compareAttrSetsM f valueEqM) + (compareAttrSetsM findNVStr valueEqM) valueEqM x y where - f = + findNVStr :: NValue t f m -> m (Maybe NixString) + findNVStr = free (pure . (\case @@ -195,7 +187,9 @@ _ -> mempty ) -thunkEqM :: (MonadThunk t m (NValue t f m), Comonad f) => t -> t -> m Bool +-- This function has mutual recursion with `valueEqM`, and this function so far is not used across the project, +-- but that one is. +thunkEqM :: (MonadThunk t m (NValue t f m), NVConstraint f) => t -> t -> m Bool thunkEqM lt rt = do lv <- force lt @@ -203,9 +197,10 @@ let unsafePtrEq = - case (lt, rt) of - (thunkId -> lid, thunkId -> rid) | lid == rid -> pure True - _ -> valueEqM lv rv + bool + (valueEqM lv rv) + (pure True) + $ on (==) thunkId lt rt case (lv, rv) of (NVClosure _ _, NVClosure _ _) -> unsafePtrEq diff --git a/tests/EvalTests.hs b/tests/EvalTests.hs --- a/tests/EvalTests.hs +++ b/tests/EvalTests.hs @@ -534,6 +534,11 @@ "true" "let nested = { y = _: (let x = x; in x); }; in nested == nested" +case_if_follow_by_with = + constantEqualText + "1" + "let x = { a = true; b = 2; }; in if with x; a then 1 else 2" + -- Regression test for #527 case_add_string_thunk_left = @@ -646,7 +651,7 @@ (normalForm =<< nixEvalExprLoc mempty a') ) (\(_ :: NixException) -> pure True) - unless errored $ assertFailure "Did not catch nix exception" + when (not errored) $ assertFailure "Did not catch nix exception" sameFreeVars :: Text -> [VarName] -> Assertion sameFreeVars a xs = @@ -657,7 +662,7 @@ assertEqual mempty (S.fromList xs) free' maskedFiles :: [Path] -maskedFiles = one "builtins.fetchurl-01.nix" +maskedFiles = mempty testDir :: Path testDir = "tests/eval-compare" diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -35,7 +35,7 @@ ensureLangTestsPresent :: Assertion ensureLangTestsPresent = do exist <- fileExist "data/nix/tests/local.mk" - unless exist $ + when (not exist) $ errorWithoutStackTrace $ String.unlines [ "Directory data/nix does not have any files." , "Did you forget to run" @@ -56,26 +56,30 @@ time <- getCurrentTime runWithBasicEffectsIO (defaultOptions time) $ Nix.nixEvalExprLoc mempty expr - let dir = ignoreContext ns - exists <- fileExist $ toString dir - unless exists $ + let dir = toString $ ignoreContext ns + exists <- fileExist dir + when (not exists) $ errorWithoutStackTrace $ "Directory " <> show dir <> " does not exist" - files <- globDir1 (compile "**/*.nix") $ toString dir - when (null files) $ - errorWithoutStackTrace $ - "Directory " <> show dir <> " does not have any files" - for_ files $ \file -> - unless ("azure-cli/default.nix" `isSuffixOf` file || - "os-specific/linux/udisks/2-default.nix" `isSuffixOf` file) $ do - -- Parse and deepseq the resulting expression tree, to ensure the - -- parser is fully executed. - _ <- consider (coerce file) (parseNixFileLoc (coerce file)) $ Exc.evaluate . force - stub + files <- globDir1 (compile "**/*.nix") dir + handlePresence + (errorWithoutStackTrace $ + "Directory " <> show dir <> " does not have any files") + (traverse_ + (\ path -> + let notEndsIn suffix = not $ isSuffixOf suffix path in + when + (on (&&) notEndsIn "azure-cli/default.nix" "os-specific/linux/udisks/2-default.nix") + $ -- Parse and deepseq the resulting expression tree, to ensure the + -- parser is fully executed. + mempty <$ consider (coerce path) (parseNixFileLoc (coerce path)) $ Exc.evaluate . force + ) + ) + files v -> fail $ "Unexpected parse from default.nix: " <> show v where getExpr k m = - let Just (Just r) = lookup k m in + let Just r = join $ lookup k m in r getString k m = let Fix (NStr (DoubleQuoted [Plain str])) = getExpr k m in diff --git a/tests/ParserTests.hs b/tests/ParserTests.hs --- a/tests/ParserTests.hs +++ b/tests/ParserTests.hs @@ -383,7 +383,15 @@ "if true then false else false else" "1 + 2 then" +-- ** If follow by with +case_if_follow_by_with = checks + ( + mkLets (one $ "x" $= mkNonRecSet ["a" $= mkBool True, "b" $= mkInt 2 ]) + $ mkIf (mkWith (mkSym "x") (mkSym "a")) (mkInt 1) (mkInt 2) + , "let x = { a = true; b = 2; }; in if with x; a then 1 else 2" + ) + -- ** Literal expressions in vals case_identifier_keyword_prefix_invariants = @@ -649,7 +657,7 @@ case_simpleLoc = let - mkSPos = on (SourcePos "") mkPos + mkSPos = on (NSourcePos "") (coerce . mkPos) mkSpan = on SrcSpan (uncurry mkSPos) in assertParseTextLoc [text|let @@ -662,12 +670,10 @@ (one $ NamedVar (one $ StaticKey "foo") - (NBinaryAnn + (NAppAnn (mkSpan (2, 7) (3, 15)) - NApp - (NBinaryAnn + (NAppAnn (mkSpan (2, 7) (3, 9)) - NApp (NSymAnn (mkSpan (2, 7) (2, 10)) "bar") (NSymAnn (mkSpan (3, 6) (3, 9 )) "baz") ) diff --git a/tests/PrettyParseTests.hs b/tests/PrettyParseTests.hs --- a/tests/PrettyParseTests.hs +++ b/tests/PrettyParseTests.hs @@ -22,7 +22,6 @@ import Prettyprinter import Test.Tasty import Test.Tasty.Hedgehog -import Text.Megaparsec ( Pos ) import qualified Text.Show.Pretty as PS asciiString :: MonadGen m => m String @@ -35,16 +34,16 @@ asciiVarName = coerce <$> asciiText -- Might want to replace this instance with a constant value -genPos :: Gen Pos -genPos = mkPos <$> Gen.int (Range.linear 1 256) +genNPos :: Gen NPos +genNPos = fmap coerce $ mkPos <$> Gen.int (Range.linear 1 256) -genSourcePos :: Gen SourcePos -genSourcePos = +genNSourcePos :: Gen NSourcePos +genNSourcePos = join (liftA3 - SourcePos - asciiString + NSourcePos + (fmap coerce asciiString) ) - genPos + genNPos genKeyName :: Gen (NKeyName NExpr) genKeyName = @@ -59,11 +58,11 @@ [ liftA3 NamedVar genAttrPath genExpr - genSourcePos + genNSourcePos , liftA3 Inherit (Gen.maybe genExpr) (Gen.list (Range.linear 0 5) asciiVarName) - genSourcePos + genNSourcePos ] genString :: Gen (NString NExpr)