diff --git a/ChangeLog.md b/ChangeLog.md index f32f08b52..bee3685c4 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -137,7 +137,9 @@ MonadPaths (Fix1 t) :: Nix.Standard -> Nix.Effects MonadPutStr (Fix1 t) :: Nix.Standard -> Nix.Effects ``` + * [(link)](https://github.com/haskell-nix/hnix/pull/878/files) `nvSet{,',P}`: got unflipped, now accept source position argument before the value. + * [(link)](https://github.com/haskell-nix/hnix/pull/878/files) `mkNixDoc`: got unflipped. * Additional: * [(link)](https://github.com/haskell-nix/hnix/commit/7e6cd97bf3288cb584241611fdb25bf85d7e0ba7) `cabal.project`: freed from the `cryptohash-sha512` override, Hackage trustees made a revision. diff --git a/src/Nix.hs b/src/Nix.hs index dadaf3470..1e6885846 100644 --- a/src/Nix.hs +++ b/src/Nix.hs @@ -129,7 +129,7 @@ evaluateExpression mpath evaluator handler expr = do eval' = normalForm <=< nixEvalExpr mpath - argmap args = nvSet (M.fromList args) mempty + argmap args = nvSet mempty (M.fromList args) processResult :: forall e t f m a diff --git a/src/Nix/Builtins.hs b/src/Nix/Builtins.hs index 20ad6d3d5..4b838e5b5 100644 --- a/src/Nix/Builtins.hs +++ b/src/Nix/Builtins.hs @@ -120,11 +120,14 @@ withNixContext mpath action = ) mpath -builtins :: (MonadNix e t f m, Scoped (NValue t f m) m) - => m (Scopes m (NValue t f m)) +builtins + :: ( MonadNix e t f m + , Scoped (NValue t f m) m + ) + => m (Scopes m (NValue t f m)) builtins = do - ref <- defer $ (`nvSet` M.empty) <$> buildMap + ref <- defer $ nvSet mempty <$> buildMap lst <- ([("builtins", ref)] <>) <$> topLevelBuiltins pushScope (M.fromList lst) currentScopes where @@ -394,7 +397,7 @@ nixPath :: MonadNix e t f m => m (NValue t f m) nixPath = fmap nvList $ flip foldNixPath mempty $ \p mn ty rest -> pure $ - flip nvSet + nvSet mempty (M.fromList [case ty of @@ -883,9 +886,10 @@ catAttrs attrName xs = n <- fromStringNoContext =<< fromValue attrName l <- fromValue @[NValue t f m] xs - fmap (nvList . catMaybes) $ - forM l $ - fmap (M.lookup n) . fromValue <=< demand + nvList . catMaybes <$> + traverse + (fmap (M.lookup n) . fromValue <=< demand) + l baseNameOf :: MonadNix e t f m => NValue t f m -> m (NValue t f m) baseNameOf x = do @@ -1010,7 +1014,7 @@ genList f nixN = n <- fromValue @Integer nixN bool (throwError $ ErrorCall $ "builtins.genList: Expected a non-negative number, got " <> show n) - (toValue =<< forM [0 .. n - 1] (defer . callFunc f <=< toValue)) + (toValue =<< traverse (defer . callFunc f <=< toValue) [0 .. n - 1]) (n >= 0) -- We wrap values solely to provide an Ord instance for genericClosure @@ -1195,7 +1199,7 @@ intersectAttrs set1 set2 = (s1, p1) <- fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) set1 (s2, p2) <- fromValue @(AttrSet (NValue t f m), AttrSet SourcePos) set2 - pure $ nvSet (s2 `M.intersection` s1) (p2 `M.intersection` p1) + pure $ nvSet (p2 `M.intersection` p1) (s2 `M.intersection` s1) functionArgs :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) @@ -1311,7 +1315,7 @@ throw_ mnv = import_ :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -import_ = scopedImport (nvSet M.empty M.empty) +import_ = scopedImport (nvSet mempty mempty) scopedImport :: forall e t f m @@ -1433,17 +1437,17 @@ listToAttrs lst = do l <- fromValue @[NValue t f m] lst fmap - ((`nvSet` M.empty) . M.fromList . reverse) - (forM l $ + (nvSet mempty . M.fromList . reverse) + (traverse (\ nvattrset -> do - a <- fromValue @(AttrSet (NValue t f m)) nvattrset - n <- fromValue =<< demand =<< attrsetGet "name" a - name <- fromStringNoContext n + a <- fromValue @(AttrSet (NValue t f m)) =<< demand nvattrset + name <- fromStringNoContext =<< fromValue =<< demand =<< attrsetGet "name" a val <- attrsetGet "value" a pure (name, val) - ) <=< demand + ) + l ) -- prim_hashString from nix/src/libexpr/primops.cc @@ -1596,7 +1600,7 @@ fromJSON nvjson = where jsonToNValue = \case - A.Object m -> (`nvSet` M.empty) <$> traverse jsonToNValue m + A.Object m -> nvSet mempty <$> traverse jsonToNValue m A.Array l -> nvList <$> traverse jsonToNValue (V.toList l) A.String s -> pure $ nvStr $ makeNixStringWithoutContext s A.Number n -> @@ -1643,12 +1647,12 @@ tryEval :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) tryEval e = catch (onSuccess <$> demand e) (pure . onError) where - onSuccess v = flip nvSet M.empty $ M.fromList + onSuccess v = nvSet mempty $ M.fromList [ ("success", nvConstant (NBool True)) , ("value", v)] onError :: SomeException -> NValue t f m - onError _ = flip nvSet M.empty $ M.fromList + onError _ = nvSet mempty $ M.fromList [ ("success", nvConstant (NBool False)) , ("value" , nvConstant (NBool False)) ] @@ -1664,7 +1668,7 @@ trace_ msg action = traceEffect @t @f @m . Text.unpack . stringIgnoreContext =<< fromValue msg pure action --- 2018-09-08: NOTE: Remember of error context is so far not implemented +-- Please, can function remember error context addErrorContext :: forall e t f m . MonadNix e t f m @@ -1755,7 +1759,7 @@ getContext = (NVStr ns) -> do let context = getNixLikeContext $ toNixLikeContext $ NixString.getContext ns valued :: M.HashMap Text (NValue t f m) <- sequenceA $ M.map toValue context - pure $ nvSet valued M.empty + pure $ nvSet mempty valued x -> throwError $ ErrorCall $ "Invalid type for builtins.getContext: " <> show x) <=< demand appendContext diff --git a/src/Nix/Convert.hs b/src/Nix/Convert.hs index 2b55ce0be..0de13c949 100644 --- a/src/Nix/Convert.hs +++ b/src/Nix/Convert.hs @@ -391,7 +391,7 @@ instance ( Convertible e t f m l' <- toValue (unPos l) c' <- toValue (unPos c) let pos = M.fromList [("file" :: Text, f'), ("line", l'), ("column", c')] - pure $ nvSet' pos mempty + pure $ nvSet' mempty pos -- | With 'ToValue', we can always act recursively instance Convertible e t f m @@ -404,33 +404,35 @@ instance (Convertible e t f m, ToValue a m (NValue t f m)) 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 $ nvSet' s mempty + 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 = (Deeper .) . nvSet' <$> traverse toValue s <*> pure mempty + toValue s = (\ v s -> Deeper $ nvSet' s v) <$> (traverse (toValue) s) <*> pure mempty instance Convertible e t f m => ToValue (AttrSet (NValue t f m), AttrSet SourcePos) m (NValue' t f m (NValue t f m)) where - toValue (s, p) = pure $ nvSet' s p + toValue (s, p) = pure $ nvSet' p s instance (Convertible e t f m, ToValue a m (NValue t f m)) => ToValue (AttrSet a, AttrSet SourcePos) m (Deeper (NValue' t f m (NValue t f m))) where - toValue (s, p) = (Deeper .) . nvSet' <$> traverse toValue s <*> pure p + toValue (s, p) = (\ v s -> Deeper $ nvSet' s v) <$> (traverse (toValue) s) <*> pure p instance Convertible e t f m => ToValue NixLikeContextValue m (NValue' t f m (NValue t f m)) where toValue nlcv = do path <- - if nlcvPath nlcv - then pure <$> toValue True - else pure Nothing + bool + (pure Nothing) + (pure <$> toValue True) + (nlcvPath nlcv) allOutputs <- - if nlcvAllOutputs nlcv - then pure <$> toValue True - else pure Nothing + bool + (pure Nothing) + (pure <$> toValue True) + (nlcvAllOutputs nlcv) outputs <- do let outputs = makeNixStringWithoutContext <$> nlcvOutputs nlcv @@ -440,7 +442,7 @@ instance Convertible e t f m (pure Nothing) (fmap pure . toValue) ts - pure $ flip nvSet' M.empty $ 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 index 86828c842..7973eea59 100644 --- a/src/Nix/Effects.hs +++ b/src/Nix/Effects.hs @@ -53,15 +53,24 @@ import qualified System.Nix.StorePath as Store -- | A path into the nix store newtype StorePath = StorePath { unStorePath :: FilePath } -class (MonadFile m, - MonadStore m, - MonadPutStr m, - MonadHttp m, - MonadEnv m, - MonadPaths m, - MonadInstantiate m, - MonadExec m, - MonadIntrospect m) => MonadEffects t f m where + +-- All of the following type classes defer to the underlying 'm'. + +-- * @class MonadEffects t f m@ + +class + ( MonadFile m + , MonadStore m + , MonadPutStr m + , MonadHttp m + , MonadEnv m + , MonadPaths m + , MonadInstantiate m + , MonadExec m + , MonadIntrospect m + ) + => MonadEffects t f m where + -- | Determine the absolute path of relative path in the current context makeAbsolutePath :: FilePath -> m FilePath findEnvPath :: String -> m FilePath @@ -77,33 +86,68 @@ class (MonadFile m, traceEffect :: String -> m () -instance (MonadFix1T t m, MonadStore m) => MonadStore (Fix1T t m) where + +-- ** Instances + +instance + ( MonadFix1T t m + , MonadStore m + ) + => MonadStore (Fix1T t m) + where addToStore a b c d = lift $ addToStore a b c d addTextToStore' a b c d = lift $ addTextToStore' a b c d -class Monad m => MonadIntrospect m where +-- * @class MonadIntrospect m@ + +class + Monad m + => MonadIntrospect m + where recursiveSize :: a -> m Word default recursiveSize :: (MonadTrans t, MonadIntrospect m', m ~ t m') => a -> m Word recursiveSize = lift . recursiveSize + +-- ** Instances + instance MonadIntrospect IO where recursiveSize = #ifdef MIN_VERSION_ghc_datasize #if MIN_VERSION_ghc_datasize(0,2,0) -recursiveSize + recursiveSize #else -\_ -> pure 0 + \_ -> pure 0 #endif #else - \_ -> pure 0 + \_ -> pure 0 #endif -class Monad m => MonadExec m where +deriving + instance + MonadIntrospect (t (Fix1 t)) + => MonadIntrospect (Fix1 t) + +deriving + instance + MonadIntrospect (t (Fix1T t m) m) + => MonadIntrospect (Fix1T t m) + + +-- * @class MonadExec m@ + +class + Monad m + => MonadExec m where + exec' :: [String] -> m (Either ErrorCall NExprLoc) default exec' :: (MonadTrans t, MonadExec m', m ~ t m') => [String] -> m (Either ErrorCall NExprLoc) exec' = lift . exec' + +-- ** Instances + instance MonadExec IO where exec' = \case [] -> pure $ Left $ ErrorCall "exec: missing program" @@ -112,70 +156,90 @@ instance MonadExec IO where let t = T.strip (T.pack out) let emsg = "program[" <> prog <> "] args=" <> show args case exitCode of - ExitSuccess -> if T.null t - then pure $ Left $ ErrorCall $ "exec has no output :" <> emsg - else case parseNixTextLoc t of - Failure err -> - pure - $ Left - $ ErrorCall - $ "Error parsing output of exec: " - <> show err - <> " " - <> emsg - Success v -> pure $ Right v - err -> - pure - $ Left - $ ErrorCall - $ "exec failed: " - <> show err - <> " " - <> emsg - -class Monad m => MonadInstantiate m where + ExitSuccess -> + if T.null t + then pure $ Left $ ErrorCall $ "exec has no output :" <> emsg + else + case parseNixTextLoc t of + Failure err -> pure $ Left $ ErrorCall $ "Error parsing output of exec: " <> show err <> " " <> emsg + Success v -> pure $ Right v + err -> pure $ Left $ ErrorCall $ "exec failed: " <> show err <> " " <> emsg + +deriving + instance + MonadExec (t (Fix1 t)) + => MonadExec (Fix1 t) + +deriving + instance + MonadExec (t (Fix1T t m) m) + => MonadExec (Fix1T t m) + + +-- * @class MonadInstantiate m@ + +class + Monad m + => MonadInstantiate m where + instantiateExpr :: String -> m (Either ErrorCall NExprLoc) default instantiateExpr :: (MonadTrans t, MonadInstantiate m', m ~ t m') => String -> m (Either ErrorCall NExprLoc) instantiateExpr = lift . instantiateExpr + +-- ** Instances + instance MonadInstantiate IO where - instantiateExpr expr = do - traceM $ "Executing: " <> show - ["nix-instantiate", "--eval", "--expr ", expr] - (exitCode, out, err) <- readProcessWithExitCode "nix-instantiate" - ["--eval", "--expr", expr] - "" - case exitCode of - ExitSuccess -> case parseNixTextLoc (T.pack out) of - Failure e -> - pure - $ Left - $ ErrorCall - $ "Error parsing output of nix-instantiate: " - <> show e - Success v -> pure $ Right v - status -> - pure - $ Left - $ ErrorCall - $ "nix-instantiate failed: " - <> show status - <> ": " - <> err -pathExists :: MonadFile m => FilePath -> m Bool -pathExists = doesPathExist + instantiateExpr expr = + do + traceM $ + "Executing: " <> show ["nix-instantiate", "--eval", "--expr ", expr] + + (exitCode, out, err) <- + readProcessWithExitCode + "nix-instantiate" + ["--eval", "--expr", expr] + "" + + pure $ case exitCode of + ExitSuccess -> + case parseNixTextLoc (T.pack out) of + Failure e -> Left $ ErrorCall $ "Error parsing output of nix-instantiate: " <> show e + Success v -> Right v + status -> Left $ ErrorCall $ "nix-instantiate failed: " <> show status <> ": " <> err + +deriving + instance + MonadInstantiate (t (Fix1 t)) + => MonadInstantiate (Fix1 t) -class Monad m => MonadEnv m where - getEnvVar :: String -> m (Maybe String) - default getEnvVar :: (MonadTrans t, MonadEnv m', m ~ t m') => String -> m (Maybe String) - getEnvVar = lift . getEnvVar - getCurrentSystemOS :: m Text - default getCurrentSystemOS :: (MonadTrans t, MonadEnv m', m ~ t m') => m Text - getCurrentSystemOS = lift getCurrentSystemOS - getCurrentSystemArch :: m Text - default getCurrentSystemArch :: (MonadTrans t, MonadEnv m', m ~ t m') => m Text - getCurrentSystemArch = lift getCurrentSystemArch +deriving + instance + MonadInstantiate (t (Fix1T t m) m) + => MonadInstantiate (Fix1T t m) + + +-- * @class MonadEnv m@ + +class + Monad m + => MonadEnv m where + + getEnvVar :: String -> m (Maybe String) + default getEnvVar :: (MonadTrans t, MonadEnv m', m ~ t m') => String -> m (Maybe String) + getEnvVar = lift . getEnvVar + + getCurrentSystemOS :: m Text + default getCurrentSystemOS :: (MonadTrans t, MonadEnv m', m ~ t m') => m Text + getCurrentSystemOS = lift getCurrentSystemOS + + getCurrentSystemArch :: m Text + default getCurrentSystemArch :: (MonadTrans t, MonadEnv m', m ~ t m') => m Text + getCurrentSystemArch = lift getCurrentSystemArch + + +-- ** Instances instance MonadEnv IO where getEnvVar = lookupEnv @@ -187,64 +251,127 @@ instance MonadEnv IO where "i386" -> "i686" arch -> arch -class Monad m => MonadPaths m where - getDataDir :: m FilePath - default getDataDir :: (MonadTrans t, MonadPaths m', m ~ t m') => m FilePath - getDataDir = lift getDataDir +deriving + instance + MonadEnv (t (Fix1 t)) + => MonadEnv (Fix1 t) + +deriving + instance + MonadEnv (t (Fix1T t m) m) + => MonadEnv (Fix1T t m) + + +-- * @class MonadPaths m@ + +class + Monad m + => MonadPaths m where + getDataDir :: m FilePath + default getDataDir :: (MonadTrans t, MonadPaths m', m ~ t m') => m FilePath + getDataDir = lift getDataDir + + +-- ** Instances instance MonadPaths IO where - getDataDir = Paths_hnix.getDataDir + getDataDir = Paths_hnix.getDataDir + +deriving + instance + MonadPaths (t (Fix1 t)) + => MonadPaths (Fix1 t) + +deriving + instance + MonadPaths (t (Fix1T t m) m) + => MonadPaths (Fix1T t m) + + +-- * @class MonadHttp m@ + +class + Monad m + => MonadHttp m where -class Monad m => MonadHttp m where - getURL :: Text -> m (Either ErrorCall StorePath) - default getURL :: (MonadTrans t, MonadHttp m', m ~ t m') => Text -> m (Either ErrorCall StorePath) - getURL = lift . getURL + getURL :: Text -> m (Either ErrorCall StorePath) + default getURL :: (MonadTrans t, MonadHttp m', m ~ t m') => Text -> m (Either ErrorCall StorePath) + getURL = lift . getURL + + +-- ** Instances instance MonadHttp IO where getURL url = do let urlstr = T.unpack url traceM $ "fetching HTTP URL: " <> urlstr req <- parseRequest urlstr - manager <- if secure req - then newTlsManager - else newManager defaultManagerSettings + manager <- + if secure req + then newTlsManager + else newManager defaultManagerSettings -- print req response <- httpLbs (req { method = "GET" }) manager let status = statusCode (responseStatus response) if status /= 200 then - pure - $ Left - $ ErrorCall - $ "fail, got " - <> show status - <> " when fetching url:" - <> urlstr - else -- do + pure $ Left $ ErrorCall $ "fail, got " <> show status <> " when fetching url:" <> urlstr + else + -- do -- let bstr = responseBody response - pure - $ Left - $ ErrorCall - $ "success in downloading but hnix-store is not yet ready; url = " - <> urlstr + pure $ Left $ ErrorCall $ "success in downloading but hnix-store is not yet ready; url = " <> urlstr + +deriving + instance + MonadHttp (t (Fix1 t)) + => MonadHttp (Fix1 t) + +deriving + instance + MonadHttp (t (Fix1T t m) m) + => MonadHttp (Fix1T t m) + +-- * @class MonadPutStr m@ + +class + Monad m + => MonadPutStr m where -class Monad m => MonadPutStr m where --TODO: Should this be used *only* when the Nix to be evaluated invokes a --`trace` operation? putStr :: String -> m () default putStr :: (MonadTrans t, MonadPutStr m', m ~ t m') => String -> m () putStr = lift . putStr + +-- ** Instances + +instance MonadPutStr IO where + putStr = Prelude.putStr + +deriving + instance + MonadPutStr (t (Fix1 t)) + => MonadPutStr (Fix1 t) + +deriving + instance + MonadPutStr (t (Fix1T t m) m) + => MonadPutStr (Fix1T t m) + + +-- ** Functions + putStrLn :: MonadPutStr m => String -> m () putStrLn = putStr . (<> "\n") print :: (MonadPutStr m, Show a) => a -> m () print = putStrLn . show -instance MonadPutStr IO where - putStr = Prelude.putStr +-- * Store effects +-- ** Data type synonyms type RecursiveFlag = Bool type RepairFlag = Bool @@ -252,7 +379,11 @@ type StorePathName = Text type FilePathFilter m = FilePath -> m Bool type StorePathSet = HS.HashSet StorePath -class Monad m => MonadStore m where +-- ** @class MonadStore m@ + +class + Monad m + => MonadStore m where -- | Copy the contents of a local path to the store. The resulting store -- path is returned. Note: This does not support yet support the expected @@ -267,21 +398,21 @@ class Monad m => MonadStore m where default addTextToStore' :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m (Either ErrorCall StorePath) addTextToStore' a b c d = lift $ addTextToStore' a b c d -parseStoreResult :: Monad m => String -> (Either String a, [Store.Remote.Logger]) -> m (Either ErrorCall a) -parseStoreResult name res = case res of - (Left msg, logs) -> pure $ Left $ ErrorCall $ "Failed to execute '" <> name <> "': " <> msg <> "\n" <> show logs - (Right result, _) -> pure $ Right result + +-- *** Instances instance MonadStore IO where - addToStore name path recursive repair = case Store.makeStorePathName name of - Left err -> pure $ Left $ ErrorCall $ "String '" <> show name <> "' is not a valid path name: " <> err - Right pathName -> do - -- TODO: redesign the filter parameter - res <- Store.Remote.runStore $ Store.Remote.addToStore @'Store.SHA256 pathName path recursive (const False) repair - parseStoreResult "addToStore" res >>= \case - Left err -> pure $ Left err - Right storePath -> pure $ Right $ StorePath $ T.unpack $ T.decodeUtf8 $ Store.storePathToRawFilePath storePath + addToStore name path recursive repair = + case Store.makeStorePathName name of + Left err -> pure $ Left $ ErrorCall $ "String '" <> show name <> "' is not a valid path name: " <> err + Right pathName -> + do + -- TODO: redesign the filter parameter + res <- Store.Remote.runStore $ Store.Remote.addToStore @'Store.SHA256 pathName path recursive (const False) repair + parseStoreResult "addToStore" res >>= \case + Left err -> pure $ Left err + Right storePath -> pure $ Right $ StorePath $ T.unpack $ T.decodeUtf8 $ Store.storePathToRawFilePath storePath addTextToStore' name text references repair = do res <- Store.Remote.runStore $ Store.Remote.addTextToStore name text references repair @@ -289,6 +420,15 @@ instance MonadStore IO where Left err -> pure $ Left err Right path -> pure $ Right $ StorePath $ T.unpack $ T.decodeUtf8 $ Store.storePathToRawFilePath path + +-- ** Functions + +parseStoreResult :: Monad m => String -> (Either String a, [Store.Remote.Logger]) -> m (Either ErrorCall a) +parseStoreResult name res = + case res of + (Left msg, logs) -> pure $ Left $ ErrorCall $ "Failed to execute '" <> name <> "': " <> msg <> "\n" <> show logs + (Right result, _) -> pure $ Right result + addTextToStore :: (Framed e m, MonadStore m) => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m StorePath addTextToStore a b c d = either throwError pure =<< addTextToStore' a b c d @@ -298,20 +438,9 @@ addPath p = either throwError pure =<< addToStore (T.pack $ takeFileName p) p Tr toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath toFile_ p contents = addTextToStore (T.pack p) (T.pack contents) HS.empty False --- All of the following type classes defer to the underlying 'm'. +-- * misc + -deriving instance MonadPutStr (t (Fix1 t)) => MonadPutStr (Fix1 t) -deriving instance MonadHttp (t (Fix1 t)) => MonadHttp (Fix1 t) -deriving instance MonadEnv (t (Fix1 t)) => MonadEnv (Fix1 t) -deriving instance MonadPaths (t (Fix1 t)) => MonadPaths (Fix1 t) -deriving instance MonadInstantiate (t (Fix1 t)) => MonadInstantiate (Fix1 t) -deriving instance MonadExec (t (Fix1 t)) => MonadExec (Fix1 t) -deriving instance MonadIntrospect (t (Fix1 t)) => MonadIntrospect (Fix1 t) - -deriving instance MonadPutStr (t (Fix1T t m) m) => MonadPutStr (Fix1T t m) -deriving instance MonadHttp (t (Fix1T t m) m) => MonadHttp (Fix1T t m) -deriving instance MonadEnv (t (Fix1T t m) m) => MonadEnv (Fix1T t m) -deriving instance MonadPaths (t (Fix1T t m) m) => MonadPaths (Fix1T t m) -deriving instance MonadInstantiate (t (Fix1T t m) m) => MonadInstantiate (Fix1T t m) -deriving instance MonadExec (t (Fix1T t m) m) => MonadExec (Fix1T t m) -deriving instance MonadIntrospect (t (Fix1T t m) m) => MonadIntrospect (Fix1T t m) +-- Please, get rid of pathExists in favour of @doesPathExist@ +pathExists :: MonadFile m => FilePath -> m Bool +pathExists = doesPathExist diff --git a/src/Nix/Effects/Derivation.hs b/src/Nix/Effects/Derivation.hs index 9878d099a..bb54d773b 100644 --- a/src/Nix/Effects/Derivation.hs +++ b/src/Nix/Effects/Derivation.hs @@ -69,12 +69,12 @@ data Derivation = Derivation defaultDerivation :: Derivation defaultDerivation = Derivation { name = undefined - , outputs = Map.empty - , inputs = (Set.empty, Map.empty) + , outputs = mempty + , inputs = (mempty, mempty) , platform = undefined , builder = undefined , args = mempty - , env = Map.empty + , env = mempty , mFixed = Nothing , hashMode = Flat , useJson = False @@ -261,14 +261,14 @@ defaultDerivationStrict = fromValue @(AttrSet (NValue t f m)) >=> \s -> do -- Memoize here, as it may be our last chance in case of readonly stores. drvHash <- Store.encodeInBase Store.Base16 <$> hashDerivationModulo drv' - modify (\(a, b) -> (a, MS.insert drvPath drvHash b)) + modify (second (MS.insert drvPath drvHash)) let outputsWithContext = Map.mapWithKey (\out path -> makeNixStringWithSingletonContext path (StringContext drvPath (DerivationOutput out))) (outputs drv') drvPathWithContext = makeNixStringWithSingletonContext drvPath (StringContext drvPath AllOutputs) attrSet = M.map nvStr $ M.fromList $ ("drvPath", drvPathWithContext): Map.toList outputsWithContext -- TODO: Add location information for all the entries. -- here --v - pure $ nvSet attrSet M.empty + pure $ nvSet mempty attrSet where @@ -278,7 +278,7 @@ defaultDerivationStrict = fromValue @(AttrSet (NValue t f m)) >=> \s -> do name <- makeStorePathName (Store.unStorePathName n <> if o == "out" then "" else "-" <> o) pure $ pathToText $ Store.makeStorePath "/nix/store" ("output:" <> Text.encodeUtf8 o) h name - toStorePaths ctx = foldl (flip addToInputs) (Set.empty, Map.empty) ctx + toStorePaths ctx = foldl (flip addToInputs) (mempty, mempty) ctx addToInputs (StringContext path kind) = case kind of DirectPath -> first (Set.insert path) DerivationOutput o -> second (Map.insertWith (<>) path [o]) @@ -328,7 +328,7 @@ buildDerivationWithContext drvAttrs = do env <- if useJson then do - jsonString :: NixString <- lift $ nvalueToJSONNixString $ flip nvSet M.empty $ + jsonString :: NixString <- lift $ nvalueToJSONNixString $ nvSet mempty $ deleteKeys [ "args", "__ignoreNulls", "__structuredAttrs" ] attrs rawString :: Text <- extractNixString jsonString pure $ Map.singleton "__json" rawString diff --git a/src/Nix/Eval.hs b/src/Nix/Eval.hs index 41d5c7f74..8c00450ad 100644 --- a/src/Nix/Eval.hs +++ b/src/Nix/Eval.hs @@ -58,7 +58,13 @@ class (Show v, Monad m) => MonadEval v m where evalAssert :: v -> m v -> m v evalApp :: v -> m v -> m v evalAbs :: Params (m v) - -> (forall a. m v -> (AttrSet (m v) -> m v -> m (a, v)) -> m (a, v)) + -> ( forall a. m v + -> ( AttrSet (m v) + -> m v + -> m (a, v) + ) + -> m (a, v) + ) -> m v {- evalSelect :: v -> NonEmpty Text -> Maybe (m v) -> m v @@ -90,18 +96,19 @@ type MonadNixEval v m ) data EvalFrame m v - = EvaluatingExpr (Scopes m v) NExprLoc - | ForcingExpr (Scopes m v) NExprLoc - | Calling String SrcSpan - | SynHole (SynHoleInfo m v) - deriving (Show, Typeable) + = EvaluatingExpr (Scopes m v) NExprLoc + | ForcingExpr (Scopes m v) NExprLoc + | Calling String SrcSpan + | SynHole (SynHoleInfo m v) + deriving (Show, Typeable) instance (Typeable m, Typeable v) => Exception (EvalFrame m v) data SynHoleInfo m v = SynHoleInfo - { _synHoleInfo_expr :: NExprLoc - , _synHoleInfo_scope :: Scopes m v - } deriving (Show, Typeable) + { _synHoleInfo_expr :: NExprLoc + , _synHoleInfo_scope :: Scopes m v + } + deriving (Show, Typeable) instance (Typeable m, Typeable v) => Exception (SynHoleInfo m v) @@ -189,6 +196,7 @@ evalWithAttrSet aset body = do scope <- currentScopes :: m (Scopes m v) s <- defer $ withScopes scope aset let s' = (fmap fst . fromValue @(AttrSet v, AttrSet SourcePos)) =<< demand s + pushWeakScope s' body attrSetAlter @@ -205,7 +213,7 @@ attrSetAlter (k : ks) pos m p val = bool go (maybe - (recurse M.empty M.empty) + (recurse mempty mempty) (\x -> do (st, sp) <- fromValue @(AttrSet v, AttrSet SourcePos) =<< x @@ -228,7 +236,7 @@ attrSetAlter (k : ks) pos m p val = ) <$> attrSetAlter ks pos st sp val desugarBinds :: forall r . ([Binding r] -> r) -> [Binding r] -> [Binding r] -desugarBinds embed binds = evalState (traverse (go <=< collect) binds) M.empty +desugarBinds embed binds = evalState (traverse (go <=< collect) binds) mempty where collect :: Binding r @@ -266,103 +274,20 @@ evalBinds => Bool -> [Binding (m v)] -> m (AttrSet v, AttrSet SourcePos) -evalBinds recursive binds = do - scope <- currentScopes :: m (Scopes m v) - buildResult scope . concat =<< traverse (go scope) (moveOverridesLast binds) - where - moveOverridesLast = uncurry (<>) . partition - (\case - NamedVar (StaticKey "__overrides" :| []) _ _pos -> False - _ -> True - ) - - go :: Scopes m v -> Binding (m v) -> m [([Text], SourcePos, m v)] - go _ (NamedVar (StaticKey "__overrides" :| []) finalValue pos) = - do - (o', p') <- fromValue =<< finalValue - -- jww (2018-05-09): What to do with the key position here? - pure $ - (\ (k, v) -> - ( [k] - , fromMaybe pos (M.lookup k p') - , pure =<< demand v - ) - ) <$> - M.toList o' +evalBinds recursive binds = + do + scope <- currentScopes :: m (Scopes m v) - go _ (NamedVar pathExpr finalValue pos) = do - let - gogo :: NAttrPath (m v) -> m ([Text], SourcePos, m v) - gogo = - \case - h :| t -> - maybe - (pure - ( mempty - , nullPos - , toValue @(AttrSet v, AttrSet SourcePos) (mempty, mempty) - ) - ) - (\ k -> - list - (pure - ( [k] - , pos - , finalValue - ) - ) - (\ (x : xs) -> - do - (restOfPath, _, v) <- gogo (x :| xs) - pure - ( k : restOfPath - , pos - , v - ) - ) - t - ) - =<< evalSetterKeyName h - - fmap - (\case - -- When there are no path segments, e.g. `${null} = 5;`, we don't - -- bind anything - ([], _, _) -> mempty - result -> [result] - ) - (gogo pathExpr) - - go scope (Inherit ms names pos) = - fmap catMaybes $ forM names $ evalSetterKeyName >=> - (pure . maybe - Nothing - (\ key -> pure - ([key] - , pos - , maybe - (attrMissing (key :| []) Nothing) - (pure <=< demand) - =<< maybe - (withScopes scope $ lookupVar key) - (\ s -> - do - (attrset, _) <- fromValue @(AttrSet v, AttrSet SourcePos) =<< s - - clearScopes @v $ pushScope attrset $ lookupVar key - ) - ms - ) - ) - ) + buildResult scope . concat =<< traverse (applyBindToAdt scope) (moveOverridesLast binds) + where buildResult :: Scopes m v -> [([Text], SourcePos, m v)] -> m (AttrSet v, AttrSet SourcePos) buildResult scope bindings = do - (s, p) <- foldM insert (M.empty, M.empty) bindings + (s, p) <- foldM insert (mempty, mempty) bindings res <- bool (traverse mkThunk s) @@ -378,6 +303,91 @@ evalBinds recursive binds = do insert (m, p) (path, pos, value) = attrSetAlter path pos m p value + applyBindToAdt :: Scopes m v -> Binding (m v) -> m [([Text], SourcePos, m v)] + applyBindToAdt _ (NamedVar (StaticKey "__overrides" :| []) finalValue pos) = + do + (o', p') <- fromValue =<< finalValue + -- jww (2018-05-09): What to do with the key position here? + pure $ + (\ (k, v) -> + ( [k] + , fromMaybe pos (M.lookup k p') + , pure =<< demand v + ) + ) <$> + M.toList o' + + applyBindToAdt _ (NamedVar pathExpr finalValue pos) = + do + fmap + (\case + -- When there are no path segments, e.g. `${null} = 5;`, we don't + -- bind anything + ([], _, _) -> mempty + result -> [result] + ) + (processAttrSetKeys pathExpr) + + where + processAttrSetKeys :: NAttrPath (m v) -> m ([Text], SourcePos, m v) + processAttrSetKeys = + \case + h :| t -> + maybe + -- Empty attrset - return a stub. + (pure ( mempty, nullPos, toValue @(AttrSet v, AttrSet SourcePos) (mempty, mempty)) ) + (\ k -> + list + -- No more keys in the attrset - return the result + (pure ( [k], pos, finalValue ) ) + -- There are unprocessed keys in attrset - recurse appending the results + (\ (x : xs) -> + do + (restOfPath, _, v) <- processAttrSetKeys (x :| xs) + pure ( k : restOfPath, pos, v ) + ) + t + ) + =<< evalSetterKeyName h + + applyBindToAdt scope (Inherit ms names pos) = + catMaybes <$> + traverse + processScope + names + where + processScope + :: NKeyName (m v) + -> m (Maybe ([Text], SourcePos, m v)) + processScope nkeyname = + (\ mkey -> + do + key <- mkey + pure + ([key] + , pos + , maybe + (attrMissing (key :| []) Nothing) + (pure <=< demand) + =<< maybe + (withScopes scope $ lookupVar key) + (\ s -> + do + (attrset, _) <- fromValue @(AttrSet v, AttrSet SourcePos) =<< s + + clearScopes @v $ pushScope attrset $ lookupVar key + ) + ms + ) + ) <$> + evalSetterKeyName nkeyname + + moveOverridesLast = uncurry (<>) . partition + (\case + NamedVar (StaticKey "__overrides" :| []) _ _pos -> False + _ -> True + ) + evalSelect :: forall v m . MonadNixEval v m @@ -395,7 +405,9 @@ evalSelect aset attr = extract x path@(k :| ks) = do x' <- fromValueMay x + case x' of + Nothing -> pure $ Left (x, path) Just (s :: AttrSet v, p :: AttrSet SourcePos) | Just t <- M.lookup k s -> do @@ -404,7 +416,6 @@ evalSelect aset attr = (\ (y : ys) -> (extract ?? (y :| ys)) =<< demand t) ks | otherwise -> Left . (, path) <$> toValue (s, p) - Nothing -> pure $ Left (x, path) -- | Evaluate a component of an attribute path in a context where we are -- *retrieving* a value @@ -425,10 +436,11 @@ evalSetterKeyName :: (MonadEval v m, FromValue NixString m v) => NKeyName (m v) -> m (Maybe Text) -evalSetterKeyName = \case - StaticKey k -> pure (pure k) - DynamicKey k -> - ((pure . stringIgnoreContext) `ifJust`) <$> runAntiquoted "\n" assembleString (fromValueMay =<<) k +evalSetterKeyName = + \case + StaticKey k -> pure (pure k) + DynamicKey k -> + ((pure . stringIgnoreContext) `ifJust`) <$> runAntiquoted "\n" assembleString (fromValueMay =<<) k assembleString :: forall v m @@ -438,7 +450,7 @@ assembleString assembleString = fromParts . \case - Indented _ parts -> parts + Indented _ parts -> parts DoubleQuoted parts -> parts where fromParts = fmap (fmap mconcat . sequence) . traverse go @@ -499,9 +511,16 @@ addStackFrames :: forall v e m a . (Scoped v m, Framed e m, Typeable v, Typeable m) => Transform NExprLocF (m a) -addStackFrames f v = do - scopes <- currentScopes :: m (Scopes m v) - withFrame Info (EvaluatingExpr scopes v) (f v) +addStackFrames f v = + do + scopes <- currentScopes :: m (Scopes m v) + + -- sectioning gives GHC optimization + -- If opimization question would arrive again, check the @(`withFrameInfo` f v) $ EvaluatingExpr scopes v@ + -- for possible @scopes@ implementation @v@ type arguments sharing between runs. + (`withFrameInfo` f v) $ (`EvaluatingExpr` v) scopes + where + withFrameInfo = withFrame Info framedEvalExprLoc :: forall e v m diff --git a/src/Nix/Exec.hs b/src/Nix/Exec.hs index c7a68ca32..fad478dfe 100644 --- a/src/Nix/Exec.hs +++ b/src/Nix/Exec.hs @@ -98,10 +98,10 @@ nvListP p l = addProvenance p (nvList l) nvSetP :: MonadCited t f m => Provenance m (NValue t f m) - -> AttrSet (NValue t f m) -> AttrSet SourcePos + -> AttrSet (NValue t f m) -> NValue t f m -nvSetP p s x = addProvenance p (nvSet s x) +nvSetP p x s = addProvenance p (nvSet x s) nvClosureP :: MonadCited t f m @@ -159,11 +159,7 @@ wrapExprLoc span x = Fix (Fix (NSym_ span "<?>") <$ x) -- Currently instance is stuck in orphanage between the requirements to be MonadEval, aka Eval stage, and emposed requirement to be MonadNix (Execution stage). MonadNix constraint tries to put the cart before horse and seems superflous, since Eval in Nix also needs and can throw exceptions. It is between `nverr` and `evalError`. instance MonadNix e t f m => MonadEval (NValue t f m) m where freeVariable var = - nverr @e @t @f - $ ErrorCall - $ "Undefined variable '" - <> Text.unpack var - <> "'" + nverr @e @t @f $ ErrorCall $ "Undefined variable '" <> Text.unpack var <> "'" synHole name = do span <- currentPos @@ -174,32 +170,26 @@ instance MonadNix e t f m => MonadEval (NValue t f m) m where } attrMissing ks Nothing = - evalError @(NValue t f m) - $ ErrorCall - $ "Inheriting unknown attribute: " - <> intercalate "." (fmap Text.unpack (NE.toList ks)) + evalError @(NValue t f m) $ ErrorCall $ "Inheriting unknown attribute: " <> intercalate "." (fmap Text.unpack (NE.toList ks)) attrMissing ks (Just s) = evalError @(NValue t f m) - $ ErrorCall - $ "Could not look up attribute " - <> intercalate "." (fmap Text.unpack (NE.toList ks)) - <> " in " - <> show (prettyNValue s) + $ ErrorCall $ "Could not look up attribute " <> intercalate "." (fmap Text.unpack (NE.toList ks)) <> " in " <> show (prettyNValue s) evalCurPos = do scope <- currentScopes span@(SrcSpan delta _) <- currentPos addProvenance @_ @_ @(NValue t f m) - (Provenance scope (NSym_ span "__curPos")) + (Provenance scope (NSym_ span "__curPos")) <$> toValue delta evaledSym name val = do scope <- currentScopes span <- currentPos - pure $ addProvenance @_ @_ @(NValue t f m) - (Provenance scope (NSym_ span name)) - val + pure $ + addProvenance @_ @_ @(NValue t f m) + (Provenance scope (NSym_ span name)) + val evalConstant c = do scope <- currentScopes @@ -207,6 +197,7 @@ instance MonadNix e t f m => MonadEval (NValue t f m) m where pure $ nvConstantP (Provenance scope (NConstant_ span c)) c evalString = assembleString >=> \case + Nothing -> nverr $ ErrorCall "Failed to assemble string" Just ns -> do scope <- currentScopes span <- currentPos @@ -216,7 +207,6 @@ instance MonadNix e t f m => MonadEval (NValue t f m) m where (NStr_ span (DoubleQuoted [Plain (stringIgnoreContext ns)])) ) ns - Nothing -> nverr $ ErrorCall "Failed to assemble string" evalLiteralPath p = do scope <- currentScopes @@ -248,30 +238,30 @@ instance MonadNix e t f m => MonadEval (NValue t f m) m where evalIf c t f = do scope <- currentScopes span <- currentPos - fromValue c >>= \b -> if b - then - (\t -> addProvenance - (Provenance scope (NIf_ span (pure c) (pure t) Nothing)) - t - ) - <$> t - else - (\f -> addProvenance - (Provenance scope (NIf_ span (pure c) Nothing (pure f))) - f - ) - <$> f - - evalAssert c body = fromValue c >>= \b -> do - span <- currentPos - if b - then do - scope <- currentScopes - (\b -> - addProvenance (Provenance scope (NAssert_ span (pure c) (pure b))) b - ) - <$> body - else nverr $ Assertion span c + b <- fromValue c + + let + fun x y = addProvenance (Provenance scope (NIf_ span (pure c) x y)) + + bool + ( (\ f' -> fun Nothing (pure f') f') <$> f ) + ( (\ t' -> fun (pure t') Nothing t') <$> t ) + b + + evalAssert c body = + do + span <- currentPos + b <- fromValue c + bool + (nverr $ Assertion span c) + (do + scope <- currentScopes + (\b -> + addProvenance (Provenance scope (NAssert_ span (pure c) (pure b))) b + ) + <$> body + ) + b evalApp f x = do scope <- currentScopes @@ -282,9 +272,11 @@ instance MonadNix e t f m => MonadEval (NValue t f m) m where evalAbs p k = do scope <- currentScopes span <- currentPos - pure $ nvClosureP (Provenance scope (NAbs_ span (Nothing <$ p) Nothing)) - (void p) - (\arg -> snd <$> k (pure arg) (\_ b -> ((), ) <$> b)) + pure $ + nvClosureP + (Provenance scope (NAbs_ span (Nothing <$ p) Nothing)) + (void p) + (\arg -> snd <$> k (pure arg) (\_ b -> ((), ) <$> b)) evalError = throwError @@ -296,19 +288,19 @@ callFunc -> NValue t f m -> m (NValue t f m) callFunc fun arg = - (\fun' -> do - frames :: Frames <- asks (view hasLens) - when (length frames > 2000) $ throwError $ ErrorCall "Function call stack exhausted" - case fun' of - NVClosure _params f -> do - f arg - NVBuiltin name f -> do - span <- currentPos - withFrame Info (Calling @m @(NValue t f m) name span) (f arg) - s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do - ((`callFunc` arg) <=< (`callFunc` s)) =<< demand f - x -> throwError $ ErrorCall $ "Attempt to call non-function: " <> show x - ) =<< demand fun + do + fun' <- demand fun + frames :: Frames <- asks (view hasLens) + when (length frames > 2000) $ throwError $ ErrorCall "Function call stack exhausted" + case fun' of + NVClosure _params f -> do + f arg + NVBuiltin name f -> do + span <- currentPos + withFrame Info (Calling @m @(NValue t f m) name span) (f arg) + s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do + ((`callFunc` arg) <=< (`callFunc` s)) =<< demand f + x -> throwError $ ErrorCall $ "Attempt to call non-function: " <> show x execUnaryOp :: (Framed e m, MonadCited t f m, Show t) @@ -324,16 +316,9 @@ execUnaryOp scope span op arg = do (NNeg, NFloat f) -> unaryOp $ NFloat (-f) (NNot, NBool b ) -> unaryOp $ NBool (not b) _ -> - throwError - $ ErrorCall - $ "unsupported argument type for unary operator " - <> show op + throwError $ ErrorCall $ "unsupported argument type for unary operator " <> show op x -> - throwError - $ ErrorCall - $ "argument to unary operator" - <> " must evaluate to an atomic type: " - <> show x + throwError $ ErrorCall $ "argument to unary operator must evaluate to an atomic type: " <> show x where unaryOp = pure . nvConstantP (Provenance scope (NUnary_ span op (pure arg))) @@ -346,17 +331,14 @@ execBinaryOp -> NValue t f m -> m (NValue t f m) -> m (NValue t f m) --- 2021-02-25: NOTE: These are do blocks. Currently in the middle of the big rewrite, can not check their refactor. Please help. + execBinaryOp scope span op lval rarg = case op of NEq -> helperEq id NNEq -> helperEq not - NOr -> - helperLogic flip True - NAnd -> - helperLogic id False - NImpl -> - helperLogic id True + NOr -> helperLogic flip True + NAnd -> helperLogic id False + NImpl -> helperLogic id True _ -> do rval <- rarg @@ -367,13 +349,21 @@ execBinaryOp scope span op lval rarg = where - helperEq flag = rarg >>= \rval -> valueEqM lval rval >>= boolOp rval . flag + helperEq flag = + do + rval <- rarg + eq <- valueEqM lval rval + boolOp rval $ flag eq helperLogic flp flag = - fromValue lval >>= - flp bool - (bypass flag) - (rarg >>= \rval -> fromValue rval >>= boolOp rval) + flp bool + (bypass flag) + (do + rval <- rarg + x <- fromValue rval + boolOp rval x + ) + =<< fromValue lval boolOp rval = toBoolOp (pure rval) @@ -397,51 +387,56 @@ execBinaryOpForced -> m (NValue t f m) execBinaryOpForced scope span op lval rval = case op of - NLt -> compare (<) - NLte -> compare (<=) - NGt -> compare (>) - NGte -> compare (>=) + NLt -> compare (<) + NLte -> compare (<=) + NGt -> compare (>) + NGte -> compare (>=) NMinus -> numBinOp (-) NMult -> numBinOp (*) NDiv -> numBinOp' div (/) - NConcat -> case (lval, rval) of - (NVList ls, NVList rs) -> pure $ nvListP prov $ ls <> rs - _ -> unsupportedTypes + NConcat -> + case (lval, rval) of + (NVList ls, NVList rs) -> pure $ nvListP prov $ ls <> rs + _ -> unsupportedTypes - NUpdate -> case (lval, rval) of - (NVSet ls lp, NVSet rs rp) -> pure $ nvSetP prov (rs `M.union` ls) (rp `M.union` lp) - (NVSet ls lp, NVConstant NNull) -> pure $ nvSetP prov ls lp - (NVConstant NNull, NVSet rs rp) -> pure $ nvSetP prov rs rp - _ -> unsupportedTypes + NUpdate -> + case (lval, rval) of + (NVSet ls lp, NVSet rs rp) -> pure $ nvSetP prov (rp `M.union` lp) (rs `M.union` ls) + (NVSet ls lp, NVConstant NNull) -> pure $ nvSetP prov lp ls + (NVConstant NNull, NVSet rs rp) -> pure $ nvSetP prov rp rs + _ -> unsupportedTypes - NPlus -> case (lval, rval) of - (NVConstant _, NVConstant _) -> numBinOp (+) - - (NVStr ls, NVStr rs) -> pure $ nvStrP prov (ls `mappend` rs) - (NVStr ls, rs@NVPath{}) -> - (\rs2 -> nvStrP prov (ls `mappend` rs2)) - <$> coerceToString callFunc CopyToStore CoerceStringy rs - (NVPath ls, NVStr rs) -> case getStringNoContext rs of - Just rs2 -> nvPathP prov <$> makeAbsolutePath @t @f (ls `mappend` Text.unpack rs2) - Nothing -> throwError $ ErrorCall $ - -- data/nix/src/libexpr/eval.cc:1412 - "A string that refers to a store path cannot be appended to a path." - (NVPath ls, NVPath rs) -> nvPathP prov <$> makeAbsolutePath @t @f (ls <> rs) - - (ls@NVSet{}, NVStr rs) -> - (\ls2 -> nvStrP prov (ls2 `mappend` rs)) - <$> coerceToString callFunc DontCopyToStore CoerceStringy ls - (NVStr ls, rs@NVSet{}) -> - (\rs2 -> nvStrP prov (ls `mappend` rs2)) - <$> coerceToString callFunc DontCopyToStore CoerceStringy rs - _ -> unsupportedTypes + NPlus -> + case (lval, rval) of + (NVConstant _, NVConstant _) -> numBinOp (+) + + (NVStr ls, NVStr rs) -> pure $ nvStrP prov (ls <> rs) + (NVStr ls, rs@NVPath{}) -> + (\rs2 -> nvStrP prov (ls <> rs2)) + <$> coerceToString callFunc CopyToStore CoerceStringy rs + (NVPath ls, NVStr rs) -> + maybe + (throwError $ ErrorCall "A string that refers to a store path cannot be appended to a path.") -- data/nix/src/libexpr/eval.cc:1412 + (\ rs2 -> + nvPathP prov <$> makeAbsolutePath @t @f (ls <> Text.unpack rs2) + ) + (getStringNoContext rs) + (NVPath ls, NVPath rs) -> nvPathP prov <$> makeAbsolutePath @t @f (ls <> rs) + + (ls@NVSet{}, NVStr rs) -> + (\ls2 -> nvStrP prov (ls2 <> rs)) + <$> coerceToString callFunc DontCopyToStore CoerceStringy ls + (NVStr ls, rs@NVSet{}) -> + (\rs2 -> nvStrP prov (ls <> rs2)) + <$> coerceToString callFunc DontCopyToStore CoerceStringy rs + _ -> unsupportedTypes NEq -> alreadyHandled NNEq -> alreadyHandled NAnd -> alreadyHandled NOr -> alreadyHandled NImpl -> alreadyHandled - NApp -> throwError $ ErrorCall $ "NApp should be handled by evalApp" + NApp -> throwError $ ErrorCall "NApp should be handled by evalApp" where prov :: Provenance m (NValue t f m) @@ -474,25 +469,19 @@ execBinaryOpForced scope span op lval rval = case op of _ -> unsupportedTypes _ -> unsupportedTypes - unsupportedTypes = throwError $ ErrorCall $ - "Unsupported argument types for binary operator " - <> show op - <> ": " - <> show lval - <> ", " - <> show rval + unsupportedTypes = throwError $ ErrorCall $ "Unsupported argument types for binary operator " <> show op <> ": " <> show lval <> ", " <> show rval + + alreadyHandled = throwError $ ErrorCall $ "This cannot happen: operator " <> show op <> " should have been handled in execBinaryOp." - alreadyHandled = throwError $ ErrorCall $ - "This cannot happen: operator " - <> show op - <> " should have been handled in execBinaryOp." -- This function is here, rather than in 'Nix.String', because of the need to -- use 'throwError'. fromStringNoContext :: Framed e m => NixString -> m Text -fromStringNoContext ns = case getStringNoContext ns of - Just str -> pure str - Nothing -> throwError $ ErrorCall $ "expected string with no context, but got " <> show ns +fromStringNoContext ns = + maybe + (throwError $ ErrorCall $ "expected string with no context, but got " <> show ns) + pure + (getStringNoContext ns) addTracing :: (MonadNix e t f m, Has e Options, MonadReader Int n, Alternative n) @@ -505,14 +494,18 @@ addTracing k v = do v'@(Compose (Ann span x)) <- sequence v pure $ do opts :: Options <- asks (view hasLens) - let rendered = if verbose opts >= Chatty + let + rendered = + if verbose opts >= Chatty + then + pretty $ #ifdef MIN_VERSION_pretty_show - then pretty $ PS.ppShow (void x) + PS.ppShow (void x) #else - then pretty $ show (void x) + show (void x) #endif else prettyNix (Fix (Fix (NSym "?") <$ x)) - msg x = pretty ("eval: " <> replicate depth ' ') <> x + msg x = pretty ("eval: " <> replicate depth ' ') <> x loc <- renderLocation span (msg rendered <> " ...\n") putStr $ show loc res <- k v' @@ -522,12 +515,19 @@ addTracing k v = do evalExprLoc :: forall e t f m . MonadNix e t f m => NExprLoc -> m (NValue t f m) evalExprLoc expr = do opts :: Options <- asks (view hasLens) - if tracing opts - then join . (`runReaderT` (0 :: Int)) $ adi - (addTracing phi) - (raise (addStackFrames @(NValue t f m) . addSourcePositions)) - expr - else adi phi (addStackFrames @(NValue t f m) . addSourcePositions) expr + + bool + (adi + phi + (addStackFrames @(NValue t f m) . addSourcePositions) + ) + (join . (`runReaderT` (0 :: Int)) . + adi + (addTracing phi) + (raise (addStackFrames @(NValue t f m) . addSourcePositions)) + ) + (tracing opts) + expr where phi = Eval.eval . annotated . getCompose raise k f x = ReaderT $ \e -> k (\t -> runReaderT (f t) e) x diff --git a/src/Nix/Expr/Strings.hs b/src/Nix/Expr/Strings.hs index 3476afae7..687936665 100644 --- a/src/Nix/Expr/Strings.hs +++ b/src/Nix/Expr/Strings.hs @@ -13,7 +13,7 @@ import qualified Data.Text as T import Data.Tuple ( swap ) import Nix.Expr --- | Merge adjacent 'Plain' values with 'mappend'. +-- | Merge adjacent @Plain@ values with @<>@. mergePlain :: [Antiquoted Text r] -> [Antiquoted Text r] mergePlain [] = mempty mergePlain (Plain a : EscapedNewline : Plain b : xs) = diff --git a/src/Nix/Expr/Types.hs b/src/Nix/Expr/Types.hs index aaf416208..0467801a2 100644 --- a/src/Nix/Expr/Types.hs +++ b/src/Nix/Expr/Types.hs @@ -30,7 +30,6 @@ module Nix.Expr.Types where import qualified Codec.Serialise as Serialise import Codec.Serialise ( Serialise ) #endif -import Control.Applicative import Control.DeepSeq import Control.Monad import Data.Aeson @@ -123,8 +122,9 @@ data Params r -- -- > ParamSet [("x",Nothing)] False Nothing ~ { x } -- > ParamSet [("x",pure y)] True (pure "s") ~ s@{ x ? y, ... } - deriving (Ord, Eq, Generic, Generic1, Typeable, Data, Functor, Show, - Foldable, Traversable, NFData, Hashable) + deriving + (Ord, Eq, Generic, Generic1, Typeable, Data, NFData, Hashable, Show, + Functor, Foldable, Traversable) instance Hashable1 Params @@ -630,31 +630,41 @@ ekey => NonEmpty Text -> SourcePos -> Lens' (Fix g) (Maybe (Fix g)) -ekey keys pos f e@(Fix x) | (NSet NNonRecursive xs, ann) <- fromNExpr x = case go xs of - ((v, [] ) : _) -> fromMaybe e <$> f (pure v) - ((v, r : rest) : _) -> ekey (r :| rest) pos f v - - _ -> f Nothing <&> \case - Nothing -> e - Just v -> - let entry = NamedVar (NE.map StaticKey keys) v pos - in Fix (toNExpr (NSet NNonRecursive (entry : xs), ann)) - where - go xs = do - let keys' = NE.toList keys - (ks, rest) <- zip (inits keys') (tails keys') - case ks of - [] -> empty - j : js -> do - NamedVar ns v _p <- xs - guard $ (j : js) == (NE.toList ns ^.. traverse . _StaticKey) - pure (v, rest) +ekey keys pos f e@(Fix x) | (NSet NNonRecursive xs, ann) <- fromNExpr x = + case go xs of + ((v, [] ) : _) -> fromMaybe e <$> f (pure v) + ((v, r : rest) : _) -> ekey (r :| rest) pos f v + + _ -> + maybe + e + (\ v -> + let entry = NamedVar (NE.map StaticKey keys) v pos in + Fix (toNExpr (NSet NNonRecursive (entry : xs), ann))) + <$> + f Nothing + where + go xs = + do + let keys' = NE.toList keys + (ks, rest) <- zip (inits keys') (tails keys') + list + mempty + (\ (j : js) -> + do + NamedVar ns v _p <- xs + guard $ (j : js) == (NE.toList ns ^.. traverse . _StaticKey) + pure (v, rest) + ) + ks ekey _ _ f e = fromMaybe e <$> f Nothing stripPositionInfo :: NExpr -> NExpr stripPositionInfo = transport phi where + transport f (Fix x) = Fix $ fmap (transport f) (f x) + phi (NSet recur binds) = NSet recur $ fmap go binds phi (NLet binds body) = NLet (fmap go binds) body phi x = x diff --git a/src/Nix/Expr/Types/Annotated.hs b/src/Nix/Expr/Types/Annotated.hs index 7ebaa8ec2..307820565 100644 --- a/src/Nix/Expr/Types/Annotated.hs +++ b/src/Nix/Expr/Types/Annotated.hs @@ -138,7 +138,7 @@ stripAnn = annotated . getCompose nUnary :: Ann SrcSpan NUnaryOp -> NExprLoc -> NExprLoc nUnary (Ann s1 u) e1@(AnnE s2 _) = AnnE (s1 <> s2) (NUnary u e1) nUnary _ _ = error "nUnary: unexpected" -{-# inline nUnary#-} +{-# inline nUnary #-} nBinary :: Ann SrcSpan NBinaryOp -> NExprLoc -> NExprLoc -> NExprLoc nBinary (Ann s1 b) e1@(AnnE s2 _) e2@(AnnE s3 _) = diff --git a/src/Nix/Lint.hs b/src/Nix/Lint.hs index b4c6fbc79..3b8bc1b38 100644 --- a/src/Nix/Lint.hs +++ b/src/Nix/Lint.hs @@ -13,6 +13,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE ApplicativeDo #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -Wno-missing-methods #-} @@ -57,14 +58,14 @@ data TAtom deriving (Show, Eq, Ord) data NTypeF (m :: * -> *) r - = TConstant [TAtom] - | TStr - | TList r - | TSet (Maybe (HashMap Text r)) - | TClosure (Params ()) - | TPath - | TBuiltin String (Symbolic m -> m r) - deriving Functor + = TConstant [TAtom] + | TStr + | TList r + | TSet (Maybe (HashMap Text r)) + | TClosure (Params ()) + | TPath + | TBuiltin String (Symbolic m -> m r) + deriving Functor compareTypes :: NTypeF m r -> NTypeF m r -> Ordering compareTypes (TConstant _) (TConstant _) = EQ @@ -88,9 +89,9 @@ compareTypes _ TPath = GT compareTypes (TBuiltin _ _) (TBuiltin _ _) = EQ data NSymbolicF r - = NAny - | NMany [r] - deriving (Show, Eq, Ord, Functor, Foldable, Traversable) + = NAny + | NMany [r] + deriving (Show, Eq, Ord, Functor, Foldable, Traversable) type SThunk (m :: * -> *) = NThunkF m (Symbolic m) @@ -101,14 +102,21 @@ data Symbolic m = SV { getSV :: SValue m } | ST { getST :: SThunk m } instance Show (Symbolic m) where show _ = "<symbolic>" -everyPossible :: MonadVar m => m (Symbolic m) +everyPossible + :: MonadVar m + => m (Symbolic m) everyPossible = packSymbolic NAny -mkSymbolic :: MonadVar m => [NTypeF m (Symbolic m)] -> m (Symbolic m) +mkSymbolic + :: MonadVar m + => [NTypeF m (Symbolic m)] + -> m (Symbolic m) mkSymbolic xs = packSymbolic (NMany xs) packSymbolic - :: MonadVar m => NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m) + :: MonadVar m + => NSymbolicF (NTypeF m (Symbolic m)) + -> m (Symbolic m) packSymbolic = fmap SV . newVar unpackSymbolic @@ -333,27 +341,33 @@ instance MonadLint e m => MonadEval (Symbolic m) m where -- each time a name is looked up within the weak scope, and we want to be -- sure the action it evaluates is to force a thunk, so its value is only -- computed once. - evalWith scope body = do - s <- defer scope - pushWeakScope ?? body $ - (unpackSymbolic >=> \case - NMany [TSet (Just s')] -> pure s' - NMany [TSet Nothing] -> error "NYI: with unknown" - _ -> throwError $ ErrorCall "scope must be a set in with statement" - ) =<< demand s - - evalIf cond t f = do - t' <- t - f' <- f - let e = NIf cond t' f' - _ <- unify (void e) cond =<< mkSymbolic [TConstant [TBool]] - unify (void e) t' f' - - evalAssert cond body = do - body' <- body - let e = NAssert cond body' - _ <- unify (void e) cond =<< mkSymbolic [TConstant [TBool]] - pure body' + evalWith scope body = + do + s <- unpackSymbolic =<< demand =<< defer scope + + pushWeakScope + (case s of + NMany [TSet (Just s')] -> pure s' + NMany [TSet Nothing] -> error "NYI: with unknown" + _ -> throwError $ ErrorCall "scope must be a set in with statement" + ) + body + + evalIf cond t f = + do + t' <- t + f' <- f + let e = NIf cond t' f' + + _ <- unify (void e) cond =<< mkSymbolic [TConstant [TBool]] + unify (void e) t' f' + + evalAssert cond body = + do + body' <- body + let e = NAssert cond body' + _ <- unify (void e) cond =<< mkSymbolic [TConstant [TBool]] + pure body' evalApp = (fmap snd .) . lintApp (NBinary NApp () ()) evalAbs params _ = mkSymbolic [TClosure (void params)] @@ -367,39 +381,47 @@ lintBinaryOp -> Symbolic m -> m (Symbolic m) -> m (Symbolic m) -lintBinaryOp op lsym rarg = do - rsym <- rarg - y <- defer everyPossible - case op of - NApp -> symerr "lintBinaryOp:NApp: should never get here" - NEq -> check lsym rsym [TConstant [TInt, TBool, TNull], TStr, TList y] - NNEq -> check lsym rsym [TConstant [TInt, TBool, TNull], TStr, TList y] - - NLt -> check lsym rsym [TConstant [TInt, TBool, TNull]] - NLte -> check lsym rsym [TConstant [TInt, TBool, TNull]] - NGt -> check lsym rsym [TConstant [TInt, TBool, TNull]] - NGte -> check lsym rsym [TConstant [TInt, TBool, TNull]] - - NAnd -> check lsym rsym [TConstant [TBool]] - NOr -> check lsym rsym [TConstant [TBool]] - NImpl -> check lsym rsym [TConstant [TBool]] - - -- jww (2018-04-01): NYI: Allow Path + Str - NPlus -> check lsym rsym [TConstant [TInt], TStr, TPath] - NMinus -> check lsym rsym [TConstant [TInt]] - NMult -> check lsym rsym [TConstant [TInt]] - NDiv -> check lsym rsym [TConstant [TInt]] - - NUpdate -> check lsym rsym [TSet mempty] - - NConcat -> check lsym rsym [TList y] +lintBinaryOp op lsym rarg = + do + 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] + + NLt -> [TConstant [TInt, TBool, TNull]] + NLte -> [TConstant [TInt, TBool, TNull]] + NGt -> [TConstant [TInt, TBool, TNull]] + NGte -> [TConstant [TInt, TBool, TNull]] + + NAnd -> [TConstant [TBool]] + NOr -> [TConstant [TBool]] + NImpl -> [TConstant [TBool]] + + -- jww (2018-04-01): NYI: Allow Path + Str + NPlus -> [TConstant [TInt], TStr, TPath] + NMinus -> [TConstant [TInt]] + NMult -> [TConstant [TInt]] + NDiv -> [TConstant [TInt]] + + NUpdate -> [TSet mempty] + + NConcat -> [TList y] + + _ -> error "Should not be possible" -- symerr or this fun signature should be changed to work in type scope where - check lsym rsym xs = do - let e = NBinary op lsym rsym - m <- mkSymbolic xs - _ <- unify (void e) lsym m - _ <- unify (void e) rsym m - unify (void e) lsym rsym + check lsym rsym xs = + do + let e = NBinary op lsym rsym + + m <- mkSymbolic xs + _ <- unify (void e) lsym m + _ <- unify (void e) rsym m + unify (void e) lsym rsym infixl 1 `lintApp` lintApp @@ -451,21 +473,29 @@ instance MonadCatch (Lint s) where runLintM :: Options -> Lint s a -> ST s a runLintM opts action = do i <- newVar (1 :: Int) - runFreshIdT i $ flip runReaderT (newContext opts) $ runLint action + runFreshIdT i $ (`runReaderT` newContext opts) $ runLint action -symbolicBaseEnv :: Monad m => m (Scopes m (Symbolic m)) +symbolicBaseEnv + :: Monad m + => m (Scopes m (Symbolic m)) symbolicBaseEnv = pure emptyScopes lint :: Options -> NExprLoc -> ST s (Symbolic (Lint s)) lint opts expr = - runLintM opts - $ symbolicBaseEnv - >>= (`pushScopes` adi (Eval.eval . annotated . getCompose) - Eval.addSourcePositions - expr + runLintM opts $ + do + basis <- symbolicBaseEnv + + pushScopes + basis + (adi + (Eval.eval . annotated . getCompose) + Eval.addSourcePositions + expr ) -instance Scoped (Symbolic (Lint s)) (Lint s) where +instance + Scoped (Symbolic (Lint s)) (Lint s) where currentScopes = currentScopesReader clearScopes = clearScopesReader @(Lint s) @(Symbolic (Lint s)) pushScopes = pushScopesReader diff --git a/src/Nix/Normal.hs b/src/Nix/Normal.hs index e3123f9c9..a092fad54 100644 --- a/src/Nix/Normal.hs +++ b/src/Nix/Normal.hs @@ -4,7 +4,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Nix/Parser.hs b/src/Nix/Parser.hs index 4447b9911..e6b00fa5e 100644 --- a/src/Nix/Parser.hs +++ b/src/Nix/Parser.hs @@ -5,6 +5,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ApplicativeDo #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} @@ -48,43 +49,64 @@ where import Prelude hiding ( readFile ) -import Control.Applicative hiding ( many - , some +import Control.DeepSeq ( NFData ) +import Control.Monad ( guard + , void + , liftM2 + , msum + , MonadPlus(mplus) + ) +import Control.Monad.Combinators.Expr ( makeExprParser + , Operator( Postfix + , InfixN + , InfixR + , Prefix + , InfixL + ) + ) +import Control.Monad.State.Strict ( evalState + , MonadState(get, put) + , State ) -import Control.DeepSeq -import Control.Monad -import Control.Monad.Combinators.Expr -import Control.Monad.State.Strict import Data.Char ( isAlpha , isDigit , isSpace ) import Data.Data ( Data(..) ) import Data.Fix ( Fix(..) ) -import Data.Functor +import Data.Functor ( ($>) ) import Data.HashSet ( HashSet ) import qualified Data.HashSet as HashSet import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map -import Data.Text hiding ( foldr1 - , concat - , concatMap - , zipWith +import Data.Text ( Text + , cons + , singleton + , pack ) -import Data.Text.Encoding +import Data.Text.Encoding ( decodeUtf8 ) import Data.Typeable ( Typeable ) -import Data.Void -import GHC.Generics hiding ( Prefix ) +import Data.Void ( Void ) +import GHC.Generics ( Generic ) import Nix.Expr hiding ( ($>) ) -import Nix.Expr.Strings -import Nix.Render +import Nix.Expr.Strings ( escapeCodes + , stripIndent + , mergePlain + , removePlainEmpty + ) +import Nix.Render ( MonadFile(readFile) ) +import Nix.Utils ( bool ) import Prettyprinter ( Doc , pretty ) import Text.Megaparsec hiding ( State ) -import Text.Megaparsec.Char -import qualified Text.Megaparsec.Char.Lexer as L +import Text.Megaparsec.Char ( space1 + , string + , letterChar + , char + ) +import qualified Text.Megaparsec.Char.Lexer as Lexer infixl 3 <+> (<+>) :: MonadPlus m => m a -> m a -> m a @@ -93,63 +115,68 @@ infixl 3 <+> --------------------------------------------------------------------------------- nixExpr :: Parser NExprLoc -nixExpr = makeExprParser nixTerm $ fmap (fmap snd) (nixOperators nixSelector) +nixExpr = + makeExprParser + nixTerm $ + (fmap . fmap) + snd + (nixOperators nixSelector) antiStart :: Parser Text antiStart = symbol "${" <?> show ("${" :: String) nixAntiquoted :: Parser a -> Parser (Antiquoted a NExprLoc) nixAntiquoted p = - Antiquoted - <$> (antiStart *> nixToplevelForm <* symbol "}") - <+> Plain - <$> p - <?> "anti-quotation" + Antiquoted <$> + (antiStart *> nixToplevelForm <* symbol "}") + <+> Plain <$> + p + <?> "anti-quotation" selDot :: Parser () selDot = try (symbol "." *> notFollowedBy nixPath) <?> "." nixSelect :: Parser NExprLoc -> Parser NExprLoc -nixSelect term = do - res <- build <$> term <*> optional - ((,) <$> (selDot *> nixSelector) <*> optional (reserved "or" *> nixTerm)) - continues <- optional $ lookAhead selDot - case continues of - Nothing -> pure res - Just _ -> nixSelect (pure res) +nixSelect term = + do + res <- + build + <$> term + <*> optional + ( (,) + <$> (selDot *> nixSelector) + <*> optional (reserved "or" *> nixTerm) + ) + continues <- optional $ lookAhead selDot + + maybe + (pure res) + (const $ nixSelect (pure res)) + continues where build :: NExprLoc - -> Maybe (Ann SrcSpan (NAttrPath NExprLoc), Maybe NExprLoc) + -> Maybe ( Ann SrcSpan (NAttrPath NExprLoc) + , Maybe NExprLoc + ) -> NExprLoc - build t Nothing = t - build t (Just (s, o)) = nSelectLoc t s o + build t mexpr = + maybe + t + (uncurry (nSelectLoc t)) + mexpr nixSelector :: Parser (Ann SrcSpan (NAttrPath NExprLoc)) -nixSelector = annotateLocation $ do - (x : xs) <- keyName `sepBy1` selDot - pure $ x :| xs +nixSelector = + annotateLocation $ + do + (x : xs) <- keyName `sepBy1` selDot + pure $ x :| xs nixTerm :: Parser NExprLoc nixTerm = do c <- try $ lookAhead $ satisfy $ \x -> - pathChar x - || x - == '(' - || x - == '{' - || x - == '[' - || x - == '<' - || x - == '/' - || x - == '"' - || x - == '\'' - || x - == '^' + pathChar x || (`elem` ("({[</\"'^" :: String)) x case c of '(' -> nixSelect nixParens '{' -> nixSelect nixSet @@ -164,16 +191,17 @@ nixTerm = do $ [ nixSelect nixSet | c == 'r' ] <> [ nixPath | pathChar c ] <> if isDigit c - then [nixFloat, nixInt] + then [ nixFloat, nixInt ] else [ nixUri | isAlpha c ] <> [ nixBool | c == 't' || c == 'f' ] <> [ nixNull | c == 'n' ] - <> [nixSelect nixSym] + <> [ nixSelect nixSym ] nixToplevelForm :: Parser NExprLoc nixToplevelForm = keywords <+> nixLambda <+> nixExpr - where keywords = nixLet <+> nixIf <+> nixAssert <+> nixWith + where + keywords = nixLet <+> nixIf <+> nixAssert <+> nixWith nixSym :: Parser NExprLoc nixSym = annotateLocation1 $ mkSymF <$> identifier @@ -191,7 +219,8 @@ nixFloat = nixBool :: Parser NExprLoc nixBool = annotateLocation1 (bool "true" True <+> bool "false" False) <?> "bool" - where bool str b = mkBoolF b <$ reserved str + where + bool str b = mkBoolF b <$ reserved str nixNull :: Parser NExprLoc nixNull = annotateLocation1 (mkNullF <$ reserved "null" <?> "null") @@ -207,35 +236,25 @@ nixList = annotateLocation1 (brackets (NList <$> many nixTerm) <?> "list") pathChar :: Char -> Bool pathChar x = - isAlpha x - || isDigit x - || x - == '.' - || x - == '_' - || x - == '-' - || x - == '+' - || x - == '~' + isAlpha x || isDigit x || (`elem` ("._-+~" :: String)) x slash :: Parser Char slash = try - ( char '/' - <* notFollowedBy (satisfy (\x -> x == '/' || x == '*' || isSpace x)) - ) + ( char '/' + <* notFollowedBy (satisfy (\x -> x == '/' || x == '*' || isSpace x)) + ) <?> "slash" -- | A path surrounded by angle brackets, indicating that it should be -- looked up in the NIX_PATH environment variable at evaluation. nixSearchPath :: Parser NExprLoc -nixSearchPath = annotateLocation1 - ( mkPathF True - <$> try (char '<' *> many (satisfy pathChar <+> slash) <* symbol ">") - <?> "spath" - ) +nixSearchPath = + annotateLocation1 + (mkPathF True <$> + try (char '<' *> many (satisfy pathChar <+> slash) <* symbol ">") + <?> "spath" + ) pathStr :: Parser FilePath pathStr = lexeme $ liftM2 @@ -250,7 +269,10 @@ nixLet :: Parser NExprLoc nixLet = annotateLocation1 (reserved "let" *> (letBody <+> letBinders) <?> "let block") where - letBinders = NLet <$> nixBinders <*> (reserved "in" *> nixToplevelForm) + letBinders = + NLet + <$> nixBinders + <*> (reserved "in" *> nixToplevelForm) -- Let expressions `let {..., body = ...}' are just desugared -- into `(rec {..., body = ...}).body'. letBody = (\x -> NSelect x (StaticKey "body" :| mempty) Nothing) <$> aset @@ -258,7 +280,7 @@ nixLet = annotateLocation1 nixIf :: Parser NExprLoc nixIf = annotateLocation1 - ( NIf + (NIf <$> (reserved "if" *> nixExpr) <*> (reserved "then" *> nixToplevelForm) <*> (reserved "else" *> nixToplevelForm) @@ -267,7 +289,7 @@ nixIf = annotateLocation1 nixAssert :: Parser NExprLoc nixAssert = annotateLocation1 - ( NAssert + (NAssert <$> (reserved "assert" *> nixToplevelForm) <*> (semi *> nixToplevelForm) <?> "assert" @@ -275,7 +297,7 @@ nixAssert = annotateLocation1 nixWith :: Parser NExprLoc nixWith = annotateLocation1 - ( NWith + (NWith <$> (reserved "with" *> nixToplevelForm) <*> (semi *> nixToplevelForm) <?> "with" @@ -290,11 +312,20 @@ nixString = nStr <$> annotateLocation nixString' nixUri :: Parser NExprLoc nixUri = lexeme $ annotateLocation1 $ try $ do start <- letterChar - protocol <- many $ satisfy $ \x -> - isAlpha x || isDigit x || x `elem` ("+-." :: String) + protocol <- many $ + satisfy $ + \ x -> + isAlpha x + || isDigit x + || (`elem` ("+-." :: String)) x _ <- string ":" - address <- some $ satisfy $ \x -> - isAlpha x || isDigit x || x `elem` ("%/?:@&=+$,-_.!~*'" :: String) + address <- + some $ + satisfy $ + \ x -> + isAlpha x + || isDigit x + || (`elem` ("%/?:@&=+$,-_.!~*'" :: String)) x pure $ NStr $ DoubleQuoted [Plain $ pack $ start : protocol ++ ':' : address] @@ -304,12 +335,12 @@ nixString' = lexeme (doubleQuoted <+> indented <?> "string") doubleQuoted :: Parser (NString NExprLoc) doubleQuoted = DoubleQuoted - . removePlainEmpty - . mergePlain - <$> ( doubleQ - *> many (stringChar doubleQ (void $ char '\\') doubleEscape) - <* doubleQ - ) + . removePlainEmpty + . mergePlain <$> + ( doubleQ + *> many (stringChar doubleQ (void $ char '\\') doubleEscape) + <* doubleQ + ) <?> "double quoted string" doubleQ = void (char '"') @@ -317,40 +348,54 @@ nixString' = lexeme (doubleQuoted <+> indented <?> "string") indented :: Parser (NString NExprLoc) indented = - stripIndent - <$> ( indentedQ - *> many (stringChar indentedQ indentedQ indentedEscape) - <* indentedQ - ) + stripIndent <$> + (indentedQ + *> many (stringChar indentedQ indentedQ indentedEscape) + <* indentedQ + ) <?> "indented string" indentedQ = void (string "''" <?> "\"''\"") - indentedEscape = try $ do - indentedQ - (Plain <$> ("''" <$ char '\'' <+> "$" <$ char '$')) <+> do - _ <- char '\\' - c <- escapeCode - pure $ if c == '\n' then EscapedNewline else Plain $ singleton c + indentedEscape = + try $ + do + indentedQ + (Plain <$> ("''" <$ char '\'' <+> "$" <$ char '$')) <+> + do + _ <- char '\\' + c <- escapeCode + + pure $ + bool + EscapedNewline + (Plain $ singleton c) + (c /= '\n') stringChar end escStart esc = - Antiquoted - <$> (antiStart *> nixToplevelForm <* char '}') - <+> Plain - . singleton - <$> char '$' - <+> esc - <+> Plain - . pack - <$> some plainChar + Antiquoted <$> + (antiStart *> nixToplevelForm <* char '}') + <+> Plain . singleton <$> + char '$' <+> esc <+> Plain . pack <$> + some plainChar where plainChar = notFollowedBy (end <+> void (char '$') <+> escStart) *> anySingle - escapeCode = msum [ c <$ char e | (c, e) <- escapeCodes ] <+> anySingle + escapeCode = + msum + [ c <$ char e | (c, e) <- escapeCodes ] + <+> anySingle -- | Gets all of the arguments for a function. argExpr :: Parser (Params NExprLoc) -argExpr = msum [atLeft, onlyname, atRight] <* symbol ":" where +argExpr = + msum + [ atLeft + , onlyname + , atRight + ] + <* symbol ":" + where -- An argument not in curly braces. There's some potential ambiguity -- in the case of, for example `x:y`. Is it a lambda function `x: y`, or -- a URI `x:y`? Nix syntax says it's the latter. So we need to fail if @@ -362,65 +407,80 @@ argExpr = msum [atLeft, onlyname, atRight] <* symbol ":" where ] -- Parameters named by an identifier on the left (`args @ {x, y}`) - atLeft = try $ do - name <- identifier <* symbol "@" - (variadic, params) <- params - pure $ ParamSet params variadic (pure name) + atLeft = + try $ + do + name <- identifier <* symbol "@" + (variadic, params) <- params + pure $ ParamSet params variadic (pure name) -- Parameters named by an identifier on the right, or none (`{x, y} @ args`) - atRight = do - (variadic, params) <- params - name <- optional $ symbol "@" *> identifier - pure $ ParamSet params variadic name + atRight = + do + (variadic, params) <- params + name <- optional $ symbol "@" *> identifier + pure $ ParamSet params variadic name -- Return the parameters set. - params = do - (args, dotdots) <- braces getParams - pure (dotdots, args) + params = + do + (args, dotdots) <- braces getParams + pure (dotdots, args) -- Collects the parameters within curly braces. Returns the parameters and -- a boolean indicating if the parameters are variadic. getParams :: Parser ([(Text, Maybe NExprLoc)], Bool) - getParams = go mempty where + 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, True) <$ symbol "...") <+> getMore acc + getMore acc = -- Could be nothing, in which just return what we have so far. - option (acc, False) $ do - -- Get an argument name and an optional default. - pair <- liftM2 (,) identifier (optional $ question *> nixToplevelForm) - -- Either return this, or attempt to get a comma and restart. - option (acc <> [pair], False) $ comma *> go (acc <> [pair]) + option (acc, False) $ + do + -- Get an argument name and an optional default. + pair <- liftM2 (,) identifier (optional $ question *> nixToplevelForm) + + -- Either return this, or attempt to get a comma and restart. + option (acc <> [pair], False) $ comma *> go (acc <> [pair]) nixBinders :: Parser [Binding NExprLoc] nixBinders = (inherit <+> namedVar) `endBy` semi where - inherit = do + inherit = + do -- We can't use 'reserved' here because it would consume the whitespace -- after the keyword, which is not exactly the semantics of C++ Nix. - try $ string "inherit" *> lookAhead (void (satisfy reservedEnd)) - p <- getSourcePos - x <- whiteSpace *> optional scope - Inherit x <$> many keyName <*> pure p <?> "inherited binding" - namedVar = do - p <- getSourcePos - NamedVar - <$> (annotated <$> nixSelector) - <*> (equals *> nixToplevelForm) - <*> pure p - <?> "variable binding" + try $ string "inherit" *> lookAhead (void (satisfy reservedEnd)) + p <- getSourcePos + x <- whiteSpace *> optional scope + Inherit x + <$> many keyName + <*> pure p + <?> "inherited binding" + namedVar = + do + p <- getSourcePos + NamedVar + <$> (annotated <$> nixSelector) + <*> (equals *> nixToplevelForm) + <*> pure p + <?> "variable binding" scope = nixParens <?> "inherit scope" keyName :: Parser (NKeyName NExprLoc) -keyName = dynamicKey <+> staticKey where +keyName = dynamicKey <+> staticKey + where staticKey = StaticKey <$> identifier dynamicKey = DynamicKey <$> nixAntiquoted nixString' nixSet :: Parser NExprLoc nixSet = annotateLocation1 ((isRec <*> braces nixBinders) <?> "set") - where isRec = (reserved "rec" $> NSet NRecursive <?> "recursive set") <+> pure (NSet NNonRecursive) + where + isRec = (reserved "rec" $> NSet NRecursive <?> "recursive set") <+> pure (NSet NNonRecursive) parseNixFile :: MonadFile m => FilePath -> m (Result NExpr) parseNixFile = @@ -439,16 +499,16 @@ parseNixTextLoc = parseFromText (whiteSpace *> nixToplevelForm <* eof) {- Parser.Library -} skipLineComment' :: Tokens Text -> Parser () -skipLineComment' prefix = string prefix - *> void (takeWhileP (pure "character") (\x -> x /= '\n' && x /= '\r')) +skipLineComment' prefix = + string prefix *> void (takeWhileP (pure "character") (\x -> x /= '\n' && x /= '\r')) whiteSpace :: Parser () whiteSpace = do put =<< getSourcePos - L.space space1 lineCmnt blockCmnt + Lexer.space space1 lineCmnt blockCmnt where lineCmnt = skipLineComment' "#" - blockCmnt = L.skipBlockComment "/*" "*/" + blockCmnt = Lexer.skipBlockComment "/*" "*/" lexeme :: Parser a -> Parser a lexeme p = p <* whiteSpace @@ -458,31 +518,8 @@ symbol = lexeme . string reservedEnd :: Char -> Bool reservedEnd x = - isSpace x - || x - == '{' - || x - == '(' - || x - == '[' - || x - == '}' - || x - == ')' - || x - == ']' - || x - == ';' - || x - == ':' - || x - == '.' - || x - == '"' - || x - == '\'' - || x - == ',' + isSpace x || (`elem` ("{([})];:.\"'," :: String)) x +{-# inline reservedEnd #-} reserved :: Text -> Parser () reserved n = @@ -505,45 +542,51 @@ identifier = lexeme $ try $ do -- Braces and angles in hnix don't enclose a single expression so this type -- restriction would not be useful. parens, brackets :: Parser (NExprF f) -> Parser (NExprF f) -parens = between (symbol "(") (symbol ")") -braces = between (symbol "{") (symbol "}") +parens = between (symbol "(") (symbol ")") +braces = between (symbol "{") (symbol "}") -- angles = between (symbol "<") (symbol ">") brackets = between (symbol "[") (symbol "]") -semi = symbol ";" -comma = symbol "," +semi = symbol ";" +comma = symbol "," -- colon = symbol ":" -- dot = symbol "." -equals = symbol "=" +equals = symbol "=" question = symbol "?" integer :: Parser Integer -integer = lexeme L.decimal +integer = lexeme Lexer.decimal float :: Parser Double -float = lexeme L.float +float = lexeme Lexer.float reservedNames :: HashSet Text -reservedNames = HashSet.fromList - ["let", "in", "if", "then", "else", "assert", "with", "rec", "inherit"] +reservedNames = + HashSet.fromList + ["let", "in", "if", "then", "else", "assert", "with", "rec", "inherit"] type Parser = ParsecT Void Text (State SourcePos) +-- This is just a @Either (Doc Void) a@ data Result a = Success a | Failure (Doc Void) deriving (Show, Functor) parseFromFileEx :: MonadFile m => Parser a -> FilePath -> m (Result a) -parseFromFileEx p path = do - txt <- decodeUtf8 <$> readFile path - pure - $ either (Failure . pretty . errorBundlePretty) Success - . flip evalState (initialPos path) - $ runParserT p path txt +parseFromFileEx p path = + do + txt <- decodeUtf8 <$> readFile path + + pure $ + either + (Failure . pretty . errorBundlePretty) + Success + $ (`evalState` initialPos path) $ runParserT p path txt parseFromText :: Parser a -> Text -> Result a parseFromText p txt = - let file = "<string>" - in either (Failure . pretty . errorBundlePretty) Success - . flip evalState (initialPos file) - $ runParserT p file txt + let file = "<string>" in + either + (Failure . pretty . errorBundlePretty) + Success + $ (`evalState` initialPos file) $ (`runParserT` file) p txt {- Parser.Operators -} @@ -560,28 +603,38 @@ data NOperatorDef deriving (Eq, Ord, Generic, Typeable, Data, Show, NFData) annotateLocation :: Parser a -> Parser (Ann SrcSpan a) -annotateLocation p = do - begin <- getSourcePos - res <- p - end <- get -- The state set before the last whitespace - pure $ Ann (SrcSpan begin end) res +annotateLocation p = + do + begin <- getSourcePos + end <- get -- The state set before the last whitespace + + Ann (SrcSpan begin end) <$> p annotateLocation1 :: Parser (NExprF NExprLoc) -> Parser NExprLoc annotateLocation1 = fmap annToAnnF . annotateLocation manyUnaryOp f = foldr1 (.) <$> some f -operator "-" = lexeme . try $ string "-" <* notFollowedBy (char '>') -operator "/" = lexeme . try $ string "/" <* notFollowedBy (char '/') -operator "<" = lexeme . try $ string "<" <* notFollowedBy (char '=') -operator ">" = lexeme . try $ string ">" <* notFollowedBy (char '=') -operator n = symbol n +operator op = + case op of + "-" -> tuneLexer "-" '>' + "/" -> tuneLexer "/" '/' + "<" -> tuneLexer "<" '=' + ">" -> tuneLexer ">" '=' + n -> symbol n + where + tuneLexer opchar nonextchar = + lexeme . try $ string opchar <* notFollowedBy (char nonextchar) opWithLoc :: Text -> o -> (Ann SrcSpan o -> a) -> Parser a -opWithLoc name op f = do - Ann ann _ <- annotateLocation $ {- dbg (unpack name) $ -} - operator name - pure $ f (Ann ann op) +opWithLoc name op f = + do + Ann ann _ <- + annotateLocation $ + {- dbg (unpack name) $ -} + operator name + + pure $ f (Ann ann op) binaryN name op = (NBinaryDef name op NAssocNone, InfixN (opWithLoc name op nBinary)) @@ -613,37 +666,47 @@ nixOperators selector = {- 2 -} [ ( NBinaryDef " " NApp NAssocLeft , - -- Thanks to Brent Yorgey for showing me this trick! + -- Thanks to Brent Yorgey for showing me this trick! InfixL $ nApp <$ symbol "" ) ] , {- 3 -} - [prefix "-" NNeg] + [ prefix "-" NNeg ] , {- 4 -} [ ( NSpecialDef "?" NHasAttrOp NAssocLeft , Postfix $ symbol "?" *> (flip nHasAttr <$> selector) ) ] , {- 5 -} - [binaryR "++" NConcat] + [ binaryR "++" NConcat ] , {- 6 -} - [binaryL "*" NMult, binaryL "/" NDiv] + [ binaryL "*" NMult + , binaryL "/" NDiv + ] , {- 7 -} - [binaryL "+" NPlus, binaryL "-" NMinus] + [ binaryL "+" NPlus + , binaryL "-" NMinus + ] , {- 8 -} - [prefix "!" NNot] + [ prefix "!" NNot ] , {- 9 -} - [binaryR "//" NUpdate] + [ binaryR "//" NUpdate ] , {- 10 -} - [binaryL "<" NLt, binaryL ">" NGt, binaryL "<=" NLte, binaryL ">=" NGte] + [ binaryL "<" NLt + , binaryL ">" NGt + , binaryL "<=" NLte + , binaryL ">=" NGte + ] , {- 11 -} - [binaryN "==" NEq, binaryN "!=" NNEq] + [ binaryN "==" NEq + , binaryN "!=" NNEq + ] , {- 12 -} - [binaryL "&&" NAnd] + [ binaryL "&&" NAnd ] , {- 13 -} - [binaryL "||" NOr] + [ binaryL "||" NOr ] , {- 14 -} - [binaryR "->" NImpl] + [ binaryR "->" NImpl ] ] data OperatorInfo = OperatorInfo @@ -653,29 +716,53 @@ data OperatorInfo = OperatorInfo } deriving (Eq, Ord, Generic, Typeable, Data, Show) getUnaryOperator :: NUnaryOp -> OperatorInfo -getUnaryOperator = (m Map.!) where - m = Map.fromList $ concat $ zipWith buildEntry - [1 ..] - (nixOperators (error "unused")) - buildEntry i = concatMap $ \case - (NUnaryDef name op, _) -> [(op, OperatorInfo i NAssocNone name)] - _ -> mempty +getUnaryOperator = (m Map.!) + where + m = + Map.fromList $ + concat $ + zipWith + buildEntry + [1 ..] + (nixOperators (error "unused")) + + buildEntry i = + concatMap $ + \case + (NUnaryDef name op, _) -> [(op, OperatorInfo i NAssocNone name)] + _ -> mempty getBinaryOperator :: NBinaryOp -> OperatorInfo -getBinaryOperator = (m Map.!) where - m = Map.fromList $ concat $ zipWith buildEntry - [1 ..] - (nixOperators (error "unused")) - buildEntry i = concatMap $ \case - (NBinaryDef name op assoc, _) -> [(op, OperatorInfo i assoc name)] - _ -> mempty +getBinaryOperator = (m Map.!) + where + m = + Map.fromList $ + concat $ + zipWith + buildEntry + [1 ..] + (nixOperators (error "unused")) + + buildEntry i = + concatMap $ + \case + (NBinaryDef name op assoc, _) -> [(op, OperatorInfo i assoc name)] + _ -> mempty getSpecialOperator :: NSpecialOp -> OperatorInfo getSpecialOperator NSelectOp = OperatorInfo 1 NAssocLeft "." -getSpecialOperator o = m Map.! o where - m = Map.fromList $ concat $ zipWith buildEntry - [1 ..] - (nixOperators (error "unused")) - buildEntry i = concatMap $ \case - (NSpecialDef name op assoc, _) -> [(op, OperatorInfo i assoc name)] - _ -> mempty +getSpecialOperator o = m Map.! o + where + m = + Map.fromList $ + concat $ + zipWith + buildEntry + [1 ..] + (nixOperators (error "unused")) + + buildEntry i = + concatMap $ + \case + (NSpecialDef name op assoc, _) -> [(op, OperatorInfo i assoc name)] + _ -> mempty diff --git a/src/Nix/Pretty.hs b/src/Nix/Pretty.hs index f8e1c2358..06fe08793 100644 --- a/src/Nix/Pretty.hs +++ b/src/Nix/Pretty.hs @@ -4,7 +4,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} @@ -16,7 +15,8 @@ module Nix.Pretty where import Control.Applicative ( (<|>) ) import Control.Monad.Free -import Data.Fix ( Fix(..), foldFix ) +import Data.Fix ( Fix(..) + , foldFix ) import Data.HashMap.Lazy ( toList ) import qualified Data.HashMap.Lazy as M import qualified Data.HashSet as HashSet @@ -25,9 +25,7 @@ import Data.List ( isPrefixOf ) import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE -import Data.Maybe ( isJust - , fromMaybe - ) +import Data.Maybe ( fromMaybe ) import Data.Text ( pack , unpack , replace @@ -43,7 +41,7 @@ import Nix.Parser import Nix.String import Nix.Thunk import Nix.Value -import Prettyprinter +import Prettyprinter hiding ( list ) import Text.Read ( readMaybe ) import Nix.Utils @@ -62,14 +60,14 @@ data NixDoc ann = NixDoc -- we can add brackets appropriately } -mkNixDoc :: Doc ann -> OperatorInfo -> NixDoc ann -mkNixDoc d o = NixDoc { withoutParens = d, rootOp = o, wasPath = False } +mkNixDoc :: OperatorInfo -> Doc ann -> NixDoc ann +mkNixDoc o d = NixDoc { withoutParens = d, rootOp = o, wasPath = False } -- | A simple expression is never wrapped in parentheses. The expression -- behaves as if its root operator had a precedence higher than all -- other operators (including function application). simpleExpr :: Doc ann -> NixDoc ann -simpleExpr d = mkNixDoc d (OperatorInfo minBound NAssocNone "simple expr") +simpleExpr = mkNixDoc (OperatorInfo minBound NAssocNone "simple expr") pathExpr :: Doc ann -> NixDoc ann pathExpr d = (simpleExpr d) { wasPath = True } @@ -81,7 +79,7 @@ pathExpr d = (simpleExpr d) { wasPath = True } -- binding). leastPrecedence :: Doc ann -> NixDoc ann leastPrecedence = - flip mkNixDoc $ OperatorInfo maxBound NAssocNone "least precedence" + mkNixDoc (OperatorInfo maxBound NAssocNone "least precedence") appOp :: OperatorInfo appOp = getBinaryOperator NApp @@ -98,7 +96,7 @@ hasAttrOp = getSpecialOperator NHasAttrOp wrapParens :: OperatorInfo -> NixDoc ann -> Doc ann wrapParens op sub = bool - parens + (\ a -> "(" <> a <> ")") id (precedence (rootOp sub) < precedence op || (precedence (rootOp sub) == precedence op @@ -113,15 +111,17 @@ wrapPath :: OperatorInfo -> NixDoc ann -> Doc ann wrapPath op sub = bool (wrapParens op sub) - (dquotes $ "$" <> braces (withoutParens sub)) + ("\"${" <> withoutParens sub <> "}\"") (wasPath sub) prettyString :: NString (NixDoc ann) -> Doc ann -prettyString (DoubleQuoted parts) = dquotes . hcat . fmap prettyPart $ parts +prettyString (DoubleQuoted parts) = "\"" <> (mconcat . fmap prettyPart $ parts) <> "\"" where + -- It serializes (@unpack@) Text -> String, because the helper code is done for String, + -- please, can someone break that code. prettyPart (Plain t) = pretty . concatMap escape . unpack $ t prettyPart EscapedNewline = "''\\n" - prettyPart (Antiquoted r) = "$" <> braces (withoutParens r) + prettyPart (Antiquoted r) = "${" <> withoutParens r <> "}" escape '"' = "\\\"" escape x = maybe @@ -129,64 +129,63 @@ prettyString (DoubleQuoted parts) = dquotes . hcat . fmap prettyPart $ parts (('\\' :) . (: mempty)) (toEscapeCode x) prettyString (Indented _ parts) = group $ nest 2 $ vcat - [dsquote, content, dsquote] + ["''", content, "''"] where - dsquote = squote <> squote content = vsep . fmap prettyLine . stripLastIfEmpty . splitLines $ parts stripLastIfEmpty = reverse . f . reverse where f ([Plain t] : xs) | Text.null (strip t) = xs f xs = xs prettyLine = hcat . fmap prettyPart prettyPart (Plain t) = - pretty . unpack . replace "${" "''${" . replace "''" "'''" $ t + pretty . replace "${" "''${" . replace "''" "'''" $ t prettyPart EscapedNewline = "\\n" - prettyPart (Antiquoted r) = "$" <> braces (withoutParens r) + prettyPart (Antiquoted r) = "${" <> withoutParens r <> "}" prettyParams :: Params (NixDoc ann) -> Doc ann -prettyParams (Param n ) = pretty $ unpack n +prettyParams (Param n ) = pretty n prettyParams (ParamSet s v mname) = prettyParamSet s v <> - (\ name -> ("@" <> pretty (unpack name)) `ifTrue` not (Text.null name)) `ifJust` mname + (\ name -> ("@" <> pretty name) `ifTrue` not (Text.null name)) `ifJust` mname prettyParamSet :: ParamSet (NixDoc ann) -> Bool -> Doc ann prettyParamSet args var = encloseSep - (lbrace <> space) - (align (space <> rbrace)) + "{ " + (align " }") sep (fmap prettySetArg args <> prettyVariadic) where prettySetArg (n, maybeDef) = maybe - (pretty (unpack n)) - (\x -> pretty (unpack n) <> " ? " <> withoutParens x) + (pretty n) + (\x -> pretty n <> " ? " <> withoutParens x) maybeDef prettyVariadic = [ "..." | var ] - sep = align (comma <> space) + sep = align ", " prettyBind :: Binding (NixDoc ann) -> Doc ann prettyBind (NamedVar n v _p) = - prettySelector n <> space <> equals <> space <> withoutParens v <> semi + prettySelector n <> " = " <> withoutParens v <> ";" prettyBind (Inherit s ns _p) = - "inherit " <>scope <> align (fillSep (fmap prettyKeyName ns)) <> semi + "inherit " <> scope <> align (fillSep (fmap prettyKeyName ns)) <> ";" where - scope = ((<> space) . parens . withoutParens) `ifJust` s + scope = ((<> " ") . parens . withoutParens) `ifJust` s prettyKeyName :: NKeyName (NixDoc ann) -> Doc ann -prettyKeyName (StaticKey "") = dquotes "" -prettyKeyName (StaticKey key) | HashSet.member key reservedNames = - dquotes $ pretty $ unpack key -prettyKeyName (StaticKey key) = pretty . unpack $ key -prettyKeyName (DynamicKey key) = runAntiquoted - (DoubleQuoted [Plain "\n"]) - prettyString - (("$" <>) . braces . withoutParens) - key +prettyKeyName (StaticKey "") = "\"\"" +prettyKeyName (StaticKey key) | HashSet.member key reservedNames = "\"" <> pretty key <> "\"" +prettyKeyName (StaticKey key) = pretty key +prettyKeyName (DynamicKey key) = + runAntiquoted + (DoubleQuoted [Plain "\n"]) + prettyString + (\ x -> "${" <> withoutParens x <> "}") + key prettySelector :: NAttrPath (NixDoc ann) -> Doc ann -prettySelector = hcat . punctuate dot . fmap prettyKeyName . NE.toList +prettySelector = hcat . punctuate "." . fmap prettyKeyName . NE.toList prettyAtom :: NAtom -> NixDoc ann -prettyAtom atom = simpleExpr $ pretty $ unpack $ atomText atom +prettyAtom atom = simpleExpr $ pretty $ atomText atom prettyNix :: NExpr -> Doc ann prettyNix = withoutParens . foldFix exprFNixDoc @@ -213,61 +212,49 @@ exprFNixDoc :: NExprF (NixDoc ann) -> NixDoc ann exprFNixDoc = \case NConstant atom -> prettyAtom atom NStr str -> simpleExpr $ prettyString str - NList [] -> simpleExpr $ lbracket <> rbracket NList xs -> - simpleExpr - $ group - $ nest 2 - $ vsep - $ concat - $ [[lbracket], fmap (wrapParens appOpNonAssoc) xs, [rbracket]] - NSet NNonRecursive [] -> simpleExpr $ lbrace <> rbrace + prettyContainer "[" (wrapParens appOpNonAssoc) "]" xs NSet NNonRecursive xs -> - simpleExpr - $ group - $ nest 2 - $ vsep - $ concat - $ [[lbrace], fmap prettyBind xs, [rbrace]] - NSet NRecursive [] -> simpleExpr $ recPrefix <> lbrace <> rbrace + prettyContainer "{" prettyBind "}" xs NSet NRecursive xs -> - simpleExpr - $ group - $ nest 2 - $ vsep - $ concat - $ [[recPrefix <> lbrace], fmap prettyBind xs, [rbrace]] + prettyContainer "rec {" prettyBind "}" xs NAbs args body -> - leastPrecedence - $ nest 2 - $ vsep - $ [prettyParams args <> colon, withoutParens body] + leastPrecedence $ + nest 2 $ + vsep + [ prettyParams args <> ":" + , withoutParens body + ] NBinary NApp fun arg -> - mkNixDoc (wrapParens appOp fun <> space <> wrapParens appOpNonAssoc arg) appOp - NBinary op r1 r2 -> flip mkNixDoc opInfo $ hsep - [ wrapParens (f NAssocLeft) r1 - , pretty $ unpack $ operatorName opInfo - , wrapParens (f NAssocRight) r2 - ] + mkNixDoc appOp (wrapParens appOp fun <> " " <> wrapParens appOpNonAssoc arg) + NBinary op r1 r2 -> + mkNixDoc + opInfo $ + hsep + [ wrapParens (f NAssocLeft) r1 + , pretty $ operatorName opInfo + , wrapParens (f NAssocRight) r2 + ] where opInfo = getBinaryOperator op f x | associativity opInfo /= x = opInfo { associativity = NAssocNone } | otherwise = opInfo - NUnary op r1 -> mkNixDoc - (pretty (unpack (operatorName opInfo)) <> wrapParens opInfo r1) - opInfo + NUnary op r1 -> + mkNixDoc + opInfo + (pretty (operatorName opInfo) <> wrapParens opInfo r1) where opInfo = getUnaryOperator op NSelect r' attr o -> - (if isJust o then leastPrecedence else flip mkNixDoc selectOp) - $ wrapPath selectOp r - <> dot - <> prettySelector attr - <> ordoc + maybe + (mkNixDoc selectOp) + (const leastPrecedence) + o + $ wrapPath selectOp r <> "." <> prettySelector attr <> ordoc where - r = flip mkNixDoc selectOp $ wrapParens appOpNonAssoc r' - ordoc = maybe mempty (((space <> "or ") <>) . wrapParens appOpNonAssoc) o + r = mkNixDoc selectOp (wrapParens appOpNonAssoc r') + ordoc = ((" or " <>) . wrapParens appOpNonAssoc) `ifJust` o NHasAttr r attr -> - mkNixDoc (wrapParens hasAttrOp r <> " ? " <> prettySelector attr) hasAttrOp + mkNixDoc hasAttrOp (wrapParens hasAttrOp r <> " ? " <> prettySelector attr) NEnvPath p -> simpleExpr $ pretty ("<" <> p <> ">") NLiteralPath p -> pathExpr $ @@ -281,39 +268,46 @@ exprFNixDoc = \case ("./" <> _txt) _txt (any (`isPrefixOf` _txt) ["/", "~/", "./", "../"]) - NSym name -> simpleExpr $ pretty (unpack name) + NSym name -> simpleExpr $ pretty name NLet binds body -> - leastPrecedence - $ group - $ vsep - $ [ "let" - , indent 2 (vsep (fmap prettyBind binds)) - , "in " <> withoutParens body - ] + leastPrecedence $ + group $ + vsep + [ "let" + , indent 2 (vsep (fmap prettyBind binds)) + , "in " <> withoutParens body + ] NIf cond trueBody falseBody -> - leastPrecedence - $ group - $ nest 2 - $ vsep - $ [ "if " <> withoutParens cond - , align ("then " <> withoutParens trueBody) - , align ("else " <> withoutParens falseBody) - ] + leastPrecedence $ + group $ + nest 2 $ + sep + [ "if " <> withoutParens cond + , align ("then " <> withoutParens trueBody) + , align ("else " <> withoutParens falseBody) + ] NWith scope body -> - leastPrecedence - $ vsep - $ ["with " <> withoutParens scope <> semi, align $ withoutParens body] + prettyAddScope "with " scope body NAssert cond body -> - leastPrecedence - $ vsep - $ ["assert " <> withoutParens cond <> semi, align $ withoutParens body] - NSynHole name -> simpleExpr $ pretty ("^" <> unpack name) - where recPrefix = "rec" <> space + prettyAddScope "assert " cond body + NSynHole name -> simpleExpr $ pretty ("^" <> name) + where + prettyContainer h f t c = + list + (simpleExpr (h <> t)) + (const $ simpleExpr $ group $ nest 2 $ vsep $ [h] <> (f <$> c) <> [t]) + c + + prettyAddScope h c b = + leastPrecedence $ + vsep + [h <> withoutParens c <> ";", align $ withoutParens b] + valueToExpr :: forall t f m . MonadDataContext f m => NValue t f m -> NExpr valueToExpr = iterNValue (\_ _ -> thk) phi where - thk = Fix . NSym . pack $ "<expr>" + thk = Fix . NSym $ "<expr>" phi :: NValue' t f m NExpr -> NExpr phi (NVConstant' a ) = Fix $ NConstant a @@ -323,9 +317,9 @@ valueToExpr = iterNValue (\_ _ -> thk) phi [ NamedVar (StaticKey k :| mempty) v (fromMaybe nullPos (M.lookup k p)) | (k, v) <- toList s ] - phi (NVClosure' _ _ ) = Fix . NSym . pack $ "<closure>" + phi (NVClosure' _ _ ) = Fix . NSym $ "<closure>" phi (NVPath' p ) = Fix $ NLiteralPath p - phi (NVBuiltin' name _) = Fix . NSym . pack $ "builtins." <> name + phi (NVBuiltin' name _) = Fix . NSym $ "builtins." <> pack name phi _ = error "Pattern synonyms foil completeness check" mkStr ns = Fix $ NStr $ DoubleQuoted [Plain (stringIgnoreContext ns)] @@ -343,20 +337,17 @@ prettyNValueProv ) => NValue t f m -> Doc ann -prettyNValueProv v = do - let ps = citations @m @(NValue t f m) v - case ps of - [] -> prettyNValue v +prettyNValueProv v = + case citations @m @(NValue t f m) v of + [] -> prettyNVal ps -> - let v' = prettyNValue v in fillSep - [ v' - , indent 2 - $ parens - $ mconcat - $ "from: " - : fmap (prettyOriginExpr . _originExpr) ps + [ prettyNVal + , indent 2 $ + "(" <> mconcat ("from: ":(prettyOriginExpr . _originExpr <$> ps)) <> ")" ] + where + prettyNVal = prettyNValue v prettyNThunk :: forall t f m ann @@ -367,16 +358,16 @@ prettyNThunk ) => t -> m (Doc ann) -prettyNThunk t = do - let ps = citations @m @(NValue t f m) @t t - v' <- prettyNValue <$> dethunk t - pure - $ fillSep - [ v' - , indent 2 $ - parens $ - mconcat $ "thunk from: " : fmap (prettyOriginExpr . _originExpr) ps - ] +prettyNThunk t = + do + let ps = citations @m @(NValue t f m) @t t + v' <- prettyNValue <$> dethunk t + pure + $ fillSep + [ v' + , indent 2 $ + "(" <> mconcat ( "thunk from: " : fmap (prettyOriginExpr . _originExpr) ps) <> ")" + ] -- | This function is used only by the testing code. printNix :: forall t f m . MonadDataContext f m => NValue t f m -> String @@ -389,18 +380,18 @@ printNix = iterNValue (\_ _ -> thk) phi phi (NVStr' ns) = show $ stringIgnoreContext ns phi (NVList' l ) = "[ " <> unwords l <> " ]" phi (NVSet' s _) = - "{ " - <> concat - [ check (unpack k) <> " = " <> v <> "; " - | (k, v) <- sort $ toList s - ] - <> "}" + "{ " <> + concat + [ check (unpack k) <> " = " <> v <> "; " + | (k, v) <- sort $ toList s + ] <> "}" where - check v = fromMaybe - v - ( fmap (surround . show) (readMaybe v :: Maybe Int) - <|> fmap (surround . show) (readMaybe v :: Maybe Float) - ) + check v = + fromMaybe + v + (fmap (surround . show) (readMaybe v :: Maybe Int) + <|> fmap (surround . show) (readMaybe v :: Maybe Float) + ) where surround s = "\"" <> s <> "\"" phi NVClosure'{} = "<<lambda>>" phi (NVPath' fp ) = fp diff --git a/src/Nix/Reduce.hs b/src/Nix/Reduce.hs index fa9d9b1e4..6574c49fa 100644 --- a/src/Nix/Reduce.hs +++ b/src/Nix/Reduce.hs @@ -10,7 +10,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -26,7 +25,10 @@ -- original. It should be seen as an opportunistic simplifier, but which -- gives up easily if faced with any potential for ambiguity in the result. -module Nix.Reduce (reduceExpr, reducingEvalExpr) where +module Nix.Reduce + ( reduceExpr + , reducingEvalExpr + ) where import Control.Applicative import Control.Arrow ( second ) @@ -39,6 +41,7 @@ import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.State.Strict +import Data.Bifunctor ( first ) import Data.Fix ( Fix(..), foldFix, foldFixM ) import Data.HashMap.Lazy ( HashMap ) import qualified Data.HashMap.Lazy as M @@ -109,10 +112,10 @@ staticImport pann path = do (Fix (NLiteralPath_ pann path)) pos x' = Fix (NLet_ span [cur] x) - modify (\(a, b) -> (M.insert path x' a, b)) + modify (first (M.insert path x')) local (const (pure path, emptyScopes @m @NExprLoc)) $ do x'' <- foldFix reduce x' - modify (\(a, b) -> (M.insert path x'' a, b)) + modify (first (M.insert path x'')) pure x'' -- gatherNames :: NExprLoc -> HashSet VarName @@ -123,7 +126,7 @@ staticImport pann path = do reduceExpr :: (MonadIO m, MonadFail m) => Maybe FilePath -> NExprLoc -> m NExprLoc reduceExpr mpath expr = - (`evalStateT` (M.empty, MS.empty)) + (`evalStateT` (mempty, MS.empty)) . (`runReaderT` (mpath, emptyScopes)) . runReducer $ foldFix reduce expr @@ -215,13 +218,20 @@ reduce base@(NSelect_ _ _ attrs _) -- | Reduce a set by inlining its binds outside of the set -- if none of the binds inherit the super set. -reduce e@(NSet_ ann NNonRecursive binds) = do - let usesInherit = flip any binds $ \case - Inherit{} -> True - _ -> False - if usesInherit - then clearScopes @NExprLoc $ Fix . NSet_ ann NNonRecursive <$> traverse sequence binds - else Fix <$> sequence e +reduce e@(NSet_ ann NNonRecursive binds) = + do + let + usesInherit = + any + (\case + Inherit{} -> True + _ -> False + ) + binds + + if usesInherit + then clearScopes @NExprLoc $ Fix . NSet_ ann NNonRecursive <$> traverse sequence binds + else Fix <$> sequence e -- Encountering a 'rec set' construction eliminates any hope of inlining -- definitions. @@ -235,29 +245,43 @@ reduce (NWith_ ann scope body) = -- | Reduce a let binds section by pushing lambdas, -- constants and strings to the body scope. -reduce (NLet_ ann binds body) = do - s <- fmap (M.fromList . catMaybes) $ forM binds $ \case - NamedVar (StaticKey name :| []) def _pos -> def >>= \case - d@(Fix NAbs_{} ) -> pure $ pure (name, d) - d@(Fix NConstant_{}) -> pure $ pure (name, d) - d@(Fix NStr_{} ) -> pure $ pure (name, d) - _ -> pure Nothing - _ -> pure Nothing - body' <- pushScope s body - binds' <- traverse sequence binds - -- let names = gatherNames body' - -- binds' <- traverse sequence binds <&> \b -> flip filter b $ \case - -- NamedVar (StaticKey name _ :| mempty) _ -> - -- name `S.member` names - -- _ -> True - pure $ Fix $ NLet_ ann binds' body' - -- where - -- go m [] = pure m - -- go m (x:xs) = case x of - -- NamedVar (StaticKey name _ :| mempty) def -> do - -- v <- pushScope m def - -- go (M.insert name v m) xs - -- _ -> go m xs +reduce (NLet_ ann binds body) = + do + binds' <- traverse sequence binds + body' <- + (`pushScope` body) . M.fromList . catMaybes =<< + traverse + (\case + NamedVar (StaticKey name :| []) def _pos -> + let + defcase = + \case + d@(Fix NAbs_{} ) -> pure (name, d) + d@(Fix NConstant_{}) -> pure (name, d) + d@(Fix NStr_{} ) -> pure (name, d) + _ -> Nothing + in + defcase <$> def + + _ -> pure Nothing + + + ) + binds + + -- let names = gatherNames body' + -- binds' <- traverse sequence binds <&> \b -> flip filter b $ \case + -- NamedVar (StaticKey name _ :| mempty) _ -> + -- name `S.member` names + -- _ -> True + pure $ Fix $ NLet_ ann binds' body' + -- where + -- go m [] = pure m + -- go m (x:xs) = case x of + -- NamedVar (StaticKey name _ :| mempty) def -> do + -- v <- pushScope m def + -- go (M.insert name v m) xs + -- _ -> go m xs -- | Reduce an if to the relevant path if -- the condition is a boolean constant. diff --git a/src/Nix/Scope.hs b/src/Nix/Scope.hs index d3c848a44..0a6134496 100644 --- a/src/Nix/Scope.hs +++ b/src/Nix/Scope.hs @@ -18,7 +18,7 @@ import Lens.Family2 import Nix.Utils newtype Scope a = Scope { getScope :: AttrSet a } - deriving (Functor, Foldable, Traversable, Eq) + deriving (Functor, Foldable, Traversable, Eq) instance Show (Scope a) where show (Scope m) = show (M.keys m) @@ -29,10 +29,14 @@ newScope = Scope scopeLookup :: Text -> [Scope a] -> Maybe a scopeLookup key = foldr go Nothing where - go :: Scope a -> Maybe a -> Maybe a + go + :: Scope a + -> Maybe a + -> Maybe a go (Scope m) rest = M.lookup key m <|> rest -data Scopes m a = Scopes +data Scopes m a = + Scopes { lexicalScopes :: [Scope a] , dynamicScopes :: [m (Scope a)] } @@ -53,45 +57,86 @@ emptyScopes = Scopes mempty mempty class Scoped a m | m -> a where currentScopes :: m (Scopes m a) - clearScopes :: m r -> m r - pushScopes :: Scopes m a -> m r -> m r - lookupVar :: Text -> m (Maybe a) + clearScopes :: m r -> m r + pushScopes :: Scopes m a -> m r -> m r + lookupVar :: Text -> m (Maybe a) currentScopesReader - :: forall m a e . (MonadReader e m, Has e (Scopes m a)) => m (Scopes m a) + :: forall m a e + . ( MonadReader e m + , Has e (Scopes m a) + ) + => m (Scopes m a) currentScopesReader = asks (view hasLens) clearScopesReader - :: forall m a e r . (MonadReader e m, Has e (Scopes m a)) => m r -> m r + :: forall m a e r + . ( MonadReader e m + , Has e (Scopes m a) + ) + => m r + -> m r clearScopesReader = local (set hasLens (emptyScopes @m @a)) -pushScope :: Scoped a m => AttrSet a -> m r -> m r +pushScope + :: Scoped a m + => AttrSet a + -> m r + -> m r pushScope s = pushScopes (Scopes [Scope s] mempty) -pushWeakScope :: (Functor m, Scoped a m) => m (AttrSet a) -> m r -> m r +pushWeakScope + :: ( Functor m + , Scoped a m + ) + => m (AttrSet a) + -> m r + -> m r pushWeakScope s = pushScopes (Scopes mempty [Scope <$> s]) pushScopesReader - :: (MonadReader e m, Has e (Scopes m a)) => Scopes m a -> m r -> m r + :: ( MonadReader e m + , Has e (Scopes m a) + ) + => Scopes m a + -> m r + -> m r pushScopesReader s = local (over hasLens (s <>)) lookupVarReader - :: forall m a e . (MonadReader e m, Has e (Scopes m a)) => Text -> m (Maybe a) -lookupVarReader k = do - mres <- asks (scopeLookup k . lexicalScopes @m . view hasLens) - case mres of - Just sym -> pure $ pure sym - Nothing -> do - ws <- asks (dynamicScopes . view hasLens) - foldr - (\x rest -> do - mres' <- M.lookup k . getScope <$> x - case mres' of - Just sym -> pure $ pure sym - Nothing -> rest - ) - (pure Nothing) - ws - -withScopes :: Scoped a m => Scopes m a -> m r -> m r + :: forall m a e + . ( MonadReader e m + , Has e (Scopes m a) + ) + => Text + -> m (Maybe a) +lookupVarReader k = + do + mres <- asks (scopeLookup k . lexicalScopes @m . view hasLens) + + maybe + (do + ws <- asks (dynamicScopes . view hasLens) + + foldr + (\ x rest -> + do + mres' <- M.lookup k . getScope <$> x + + maybe + rest + (pure . pure) + mres' + ) + (pure Nothing) + ws + ) + (pure . pure) + mres + +withScopes + :: Scoped a m + => Scopes m a + -> m r + -> m r withScopes scope = clearScopes . pushScopes scope diff --git a/src/Nix/TH.hs b/src/Nix/TH.hs index 5661ecec2..b1a7c93d3 100644 --- a/src/Nix/TH.hs +++ b/src/Nix/TH.hs @@ -44,20 +44,20 @@ quoteExprPat s = do freeVars :: NExpr -> Set VarName freeVars e = case unFix e of - (NConstant _ ) -> Set.empty + (NConstant _ ) -> mempty (NStr string ) -> foldMap freeVars string (NSym var ) -> Set.singleton var (NList list ) -> foldMap freeVars list (NSet NNonRecursive bindings) -> foldMap bindFree bindings (NSet NRecursive bindings) -> foldMap bindFree bindings \\ foldMap bindDefs bindings - (NLiteralPath _ ) -> Set.empty - (NEnvPath _ ) -> Set.empty + (NLiteralPath _ ) -> mempty + (NEnvPath _ ) -> mempty (NUnary _ expr ) -> freeVars expr (NBinary _ left right ) -> freeVars left `Set.union` freeVars right (NSelect expr path orExpr) -> freeVars expr `Set.union` pathFree path - `Set.union` maybe Set.empty freeVars orExpr + `Set.union` maybe mempty freeVars orExpr (NHasAttr expr path) -> freeVars expr `Set.union` pathFree path (NAbs (Param varname) expr) -> Set.delete varname (freeVars expr) (NAbs (ParamSet set _ varname) expr) -> @@ -65,7 +65,7 @@ freeVars e = case unFix e of freeVars expr `Set.union` Set.unions (mapMaybe (fmap freeVars . snd) set) -- But remove the argument name if existing, and all arguments in the parameter set - \\ maybe Set.empty Set.singleton varname + \\ maybe mempty Set.singleton varname \\ Set.fromList (fmap fst set) (NLet bindings expr) -> freeVars expr @@ -77,7 +77,7 @@ freeVars e = case unFix e of -- This also makes sense because its value can be overridden by `x: with y; x` (NWith set expr) -> freeVars set `Set.union` freeVars expr (NAssert assertion expr) -> freeVars assertion `Set.union` freeVars expr - (NSynHole _ ) -> Set.empty + (NSynHole _ ) -> mempty where @@ -86,10 +86,10 @@ freeVars e = case unFix e of staticKey (DynamicKey _ ) = mempty bindDefs :: Binding r -> Set VarName - bindDefs (Inherit Nothing _ _) = Set.empty + bindDefs (Inherit Nothing _ _) = mempty bindDefs (Inherit (Just _) keys _) = Set.fromList $ mapMaybe staticKey keys bindDefs (NamedVar (StaticKey varname :| _) _ _) = Set.singleton varname - bindDefs (NamedVar (DynamicKey _ :| _) _ _) = Set.empty + bindDefs (NamedVar (DynamicKey _ :| _) _ _) = mempty bindFree :: Binding NExpr -> Set VarName bindFree (Inherit Nothing keys _) = Set.fromList $ mapMaybe staticKey keys diff --git a/src/Nix/Type/Env.hs b/src/Nix/Type/Env.hs index 1c3d451d2..c7b6719ee 100644 --- a/src/Nix/Type/Env.hs +++ b/src/Nix/Type/Env.hs @@ -21,15 +21,14 @@ import Nix.Type.Type import Data.Foldable ( foldl' ) import qualified Data.Map as Map ---------------------------------------------------------------------------------- + -- * Typing Environment ---------------------------------------------------------------------------------- newtype Env = TypeEnv { types :: Map.Map Name [Scheme] } deriving (Eq, Show) empty :: Env -empty = TypeEnv Map.empty +empty = TypeEnv mempty extend :: Env -> (Name, [Scheme]) -> Env extend env (x, s) = env { types = Map.insert x s (types env) } diff --git a/src/Nix/Type/Infer.hs b/src/Nix/Type/Infer.hs index c1355ab61..e10adb0a3 100644 --- a/src/Nix/Type/Infer.hs +++ b/src/Nix/Type/Infer.hs @@ -14,7 +14,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE InstanceSigs #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} @@ -73,28 +72,28 @@ import Nix.Utils import Nix.Value.Monad import Nix.Var ---------------------------------------------------------------------------------- + -- * Classes ---------------------------------------------------------------------------------- -- | Inference monad -newtype InferT s m a = InferT +newtype InferT s m a = + InferT { getInfer :: ReaderT (Set.Set TVar, Scopes (InferT s m) (Judgment s)) (StateT InferState (ExceptT InferError m)) a } deriving - ( Functor - , Applicative - , Alternative - , Monad - , MonadPlus - , MonadFix - , MonadReader (Set.Set TVar, Scopes (InferT s m) (Judgment s)) - , MonadFail - , MonadState InferState - , MonadError InferError - ) + ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , MonadFix + , MonadReader (Set.Set TVar, Scopes (InferT s m) (Judgment s)) + , MonadFail + , MonadState InferState + , MonadError InferError + ) instance MonadTrans (InferT s) where lift = InferT . lift . lift . lift @@ -110,10 +109,10 @@ initInfer :: InferState initInfer = InferState { count = 0 } data Constraint - = EqConst Type Type - | ExpInstConst Type Scheme - | ImpInstConst Type (Set.Set TVar) Type - deriving (Show, Eq, Ord) + = EqConst Type Type + | ExpInstConst Type Scheme + | ImpInstConst Type (Set.Set TVar) Type + deriving (Show, Eq, Ord) newtype Subst = Subst (Map TVar Type) deriving (Eq, Ord, Show, Semigroup, Monoid) @@ -156,7 +155,7 @@ class FreeTypeVars a where ftv :: a -> Set.Set TVar instance FreeTypeVars Type where - ftv TCon{} = Set.empty + ftv TCon{} = mempty ftv (TVar a ) = Set.singleton a ftv (TSet _ a ) = Set.unions (fmap ftv (M.elems a)) ftv (TList a ) = Set.unions (fmap ftv a) @@ -170,23 +169,22 @@ instance FreeTypeVars Scheme where ftv (Forall as t) = ftv t `Set.difference` Set.fromList as instance FreeTypeVars a => FreeTypeVars [a] where - ftv = foldr (Set.union . ftv) Set.empty + ftv = foldr (Set.union . ftv) mempty instance (Ord a, FreeTypeVars a) => FreeTypeVars (Set.Set a) where - ftv = foldr (Set.union . ftv) Set.empty + ftv = foldr (Set.union . ftv) mempty class ActiveTypeVars a where atv :: a -> Set.Set TVar instance ActiveTypeVars Constraint where - atv (EqConst t1 t2) = ftv t1 `Set.union` ftv t2 - atv (ImpInstConst t1 ms t2) = - ftv t1 `Set.union` (ftv ms `Set.intersection` ftv t2) - atv (ExpInstConst t s) = ftv t `Set.union` ftv s + atv (EqConst t1 t2 ) = ftv t1 `Set.union` ftv t2 + atv (ImpInstConst t1 ms t2) = ftv t1 `Set.union` (ftv ms `Set.intersection` ftv t2) + atv (ExpInstConst t s ) = ftv t `Set.union` ftv s instance ActiveTypeVars a => ActiveTypeVars [a] where - atv = foldr (Set.union . atv) Set.empty + atv = foldr (Set.union . atv) mempty data TypeError = UnificationFail Type Type @@ -214,16 +212,15 @@ instance Monoid InferError where mempty = TypeInferenceAborted mappend = (<>) ---------------------------------------------------------------------------------- + -- * Inference ---------------------------------------------------------------------------------- -- | Run the inference monad runInfer' :: MonadInfer m => InferT s m a -> m (Either InferError a) runInfer' = runExceptT . (`evalStateT` initInfer) - . (`runReaderT` (Set.empty, emptyScopes)) + . (`runReaderT` (mempty, emptyScopes)) . getInfer runInfer :: (forall s . InferT s (FreshIdT Int (ST s)) a) -> Either InferError a @@ -261,7 +258,7 @@ inferExpr env ex = case runInfer (inferType env ex) of -- | Canonicalize and return the polymorphic toplevel type. closeOver :: Type -> Scheme -closeOver = normalizeScheme . generalize Set.empty +closeOver = normalizeScheme . generalize mempty extendMSet :: Monad m => TVar -> InferT s m a -> InferT s m a extendMSet x = InferT . local (first (Set.insert x)) . getInfer @@ -536,49 +533,67 @@ instance MonadInfer m => MonadEval (Judgment s) (InferT s m) where (tv :~> t) evalAbs (ParamSet ps variadic _mname) k = do - js <- fmap concat $ forM ps $ \(name, _) -> do - tv <- fresh - pure [(name, tv)] - - let (env, tys) = - (\f -> foldl' f (As.empty, M.empty) js) $ \(as1, t1) (k, t) -> - (as1 `As.merge` As.singleton k t, M.insert k t t1) - arg = pure $ Judgment env mempty (TSet True tys) - call = k arg $ \args b -> (args, ) <$> b - names = fmap fst js + js <- + concat <$> + traverse + (\(name, _) -> + do + tv <- fresh + pure [(name, tv)] + ) + ps + + let + (env, tys) = + (\f -> foldl' f (As.empty, mempty) js) $ \(as1, t1) (k, t) -> + (as1 `As.merge` As.singleton k t, M.insert k t t1) + arg = pure $ Judgment env mempty (TSet True tys) + call = k arg $ \args b -> (args, ) <$> b + names = fmap fst js (args, Judgment as cs t) <- foldr (\(_, TVar a) -> extendMSet a) call js ty <- TSet variadic <$> traverse (inferredType <$>) args - pure $ Judgment - (foldl' As.remove as names) - (cs <> [ EqConst t' (tys M.! x) | x <- names, t' <- As.lookup x as ]) - (ty :~> t) + pure $ + Judgment + (foldl' As.remove as names) + (cs <> [ EqConst t' (tys M.! x) | x <- names, t' <- As.lookup x as ]) + (ty :~> t) evalError = throwError . EvaluationError -data Judgment s = Judgment +data Judgment s = + Judgment { assumptions :: As.Assumption , typeConstraints :: [Constraint] , inferredType :: Type } deriving Show -instance Monad m => FromValue NixString (InferT s m) (Judgment s) where +instance + Monad m + => FromValue NixString (InferT s m) (Judgment s) + where fromValueMay _ = pure mempty fromValue _ = error "Unused" -instance MonadInfer m - => FromValue (AttrSet (Judgment s), AttrSet SourcePos) - (InferT s m) (Judgment s) where - fromValueMay (Judgment _ _ (TSet _ xs)) = do - let sing _ = Judgment As.empty mempty - pure $ pure (M.mapWithKey sing xs, M.empty) +instance + MonadInfer m + => FromValue ( AttrSet (Judgment s) + , AttrSet SourcePos + ) (InferT s m) (Judgment s) + where + fromValueMay (Judgment _ _ (TSet _ xs)) = + do + let sing _ = Judgment As.empty mempty + pure $ pure (M.mapWithKey sing xs, mempty) fromValueMay _ = pure mempty - fromValue = fromValueMay >=> - pure . fromMaybe - (M.empty, M.empty) + fromValue = + pure . + fromMaybe + (mempty, mempty) + <=< fromValueMay instance MonadInfer m => ToValue (AttrSet (Judgment s), AttrSet SourcePos) @@ -586,7 +601,7 @@ instance MonadInfer m toValue (xs, _) = Judgment <$> foldrM go As.empty xs - <*> (concat <$> traverse ((pure . typeConstraints) <=< demand ) xs) + <*> (concat <$> traverse ((pure . typeConstraints) <=< demand) xs) <*> (TSet True <$> traverse ((pure . inferredType) <=< demand) xs) where go x rest = @@ -637,13 +652,14 @@ normalizeScheme (Forall _ body) = Forall (fmap snd ord) (normtype body) normtype (TSet b a) = TSet b (M.map normtype a) normtype (TList a ) = TList (fmap normtype a) normtype (TMany ts) = TMany (fmap normtype ts) - normtype (TVar a ) = case Prelude.lookup a ord of - Just x -> TVar x - Nothing -> error "type variable not in signature" + normtype (TVar a ) = + maybe + (error "type variable not in signature") + TVar + (Prelude.lookup a ord) + ---------------------------------------------------------------------------------- -- * Constraint Solver ---------------------------------------------------------------------------------- newtype Solver m a = Solver (LogicT (StateT [TypeError] m) a) deriving (Functor, Applicative, Alternative, Monad, MonadPlus, @@ -744,7 +760,9 @@ solve cs = solve' (nextSolvable cs) s' <- lift $ instantiate s solve (EqConst t s' : cs) -instance Monad m => Scoped (Judgment s) (InferT s m) where +instance + Monad m + => Scoped (Judgment s) (InferT s m) where currentScopes = currentScopesReader clearScopes = clearScopesReader @(InferT s m) @(Judgment s) pushScopes = pushScopesReader diff --git a/src/Nix/Type/Type.hs b/src/Nix/Type/Type.hs index 0b2ef1a0f..0a6b4f848 100644 --- a/src/Nix/Type/Type.hs +++ b/src/Nix/Type/Type.hs @@ -1,9 +1,10 @@ module Nix.Type.Type where -import qualified Data.HashMap.Lazy as M import Data.Text ( Text ) import Nix.Utils ( AttrSet ) +type Name = Text + -- | Hindrey-Milner type interface newtype TVar = TV String @@ -23,7 +24,7 @@ data Scheme = Forall [TVar] Type -- forall a b. a -> b -- This models a set that unifies with any other set. typeSet :: Type -typeSet = TSet True M.empty +typeSet = TSet True mempty typeList :: Type typeList = TList mempty @@ -34,11 +35,9 @@ typeFun :: [Type] -> Type typeFun = foldr1 (:~>) typeInt, typeFloat, typeBool, typeString, typePath, typeNull :: Type -typeInt = TCon "integer" -typeFloat = TCon "float" -typeBool = TCon "boolean" +typeInt = TCon "integer" +typeFloat = TCon "float" +typeBool = TCon "boolean" typeString = TCon "string" -typePath = TCon "path" -typeNull = TCon "null" - -type Name = Text +typePath = TCon "path" +typeNull = TCon "null" diff --git a/src/Nix/Utils.hs b/src/Nix/Utils.hs index c5029f720..3f6cdb983 100644 --- a/src/Nix/Utils.hs +++ b/src/Nix/Utils.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} @@ -89,9 +88,6 @@ cataP f x = f x . fmap (cataP f) . unFix $ x cataPM :: (Traversable f, Monad m) => (Fix f -> f a -> m a) -> Fix f -> m a cataPM f x = f x <=< traverse (cataPM f) . unFix $ x -transport :: Functor g => (forall x . f x -> g x) -> Fix f -> Fix g -transport f (Fix x) = Fix $ fmap (transport f) (f x) - lifted :: (MonadTransControl u, Monad (u m), Monad m) => ((a -> m (StT u b)) -> m (StT u b)) @@ -129,7 +125,7 @@ adiM adiM f g = g ((f <=< traverse (adiM f g)) . unFix) class Has a b where - hasLens :: Lens' a b + hasLens :: Lens' a b instance Has a a where hasLens f = f diff --git a/src/Nix/Value.hs b/src/Nix/Value.hs index 8c5711c85..02cc61901 100644 --- a/src/Nix/Value.hs +++ b/src/Nix/Value.hs @@ -381,10 +381,10 @@ nvList' = NValue . pure . NVListF -- | Haskell key-value to the Nix key-value, nvSet' :: Applicative f - => HashMap Text r - -> HashMap Text SourcePos + => HashMap Text SourcePos + -> HashMap Text r -> NValue' t f m r -nvSet' s x = NValue $ pure $ NVSetF s x +nvSet' x s = NValue $ pure $ NVSetF s x -- | Haskell closure to the Nix closure, @@ -549,10 +549,10 @@ nvList = Free . nvList' nvSet :: Applicative f - => HashMap Text (NValue t f m) - -> HashMap Text SourcePos + => HashMap Text SourcePos + -> HashMap Text (NValue t f m) -> NValue t f m -nvSet s x = Free $ nvSet' s x +nvSet x s = Free $ nvSet' x s nvClosure :: (Applicative f, Functor m) diff --git a/src/Nix/Value/Equal.hs b/src/Nix/Value/Equal.hs index 8a72b1190..f9804ac52 100644 --- a/src/Nix/Value/Equal.hs +++ b/src/Nix/Value/Equal.hs @@ -30,18 +30,21 @@ import Nix.Utils import Nix.Value checkComparable - :: (Framed e m, MonadDataErrorContext t f m) + :: ( Framed e m + , MonadDataErrorContext t f m + ) => NValue t f m -> NValue t f m -> m () -checkComparable x y = case (x, y) of - (NVConstant (NFloat _), NVConstant (NInt _)) -> pure () - (NVConstant (NInt _), NVConstant (NFloat _)) -> pure () - (NVConstant (NInt _), NVConstant (NInt _)) -> pure () - (NVConstant (NFloat _), NVConstant (NFloat _)) -> pure () - (NVStr _, NVStr _) -> pure () - (NVPath _, NVPath _) -> pure () - _ -> throwError $ Comparison x y +checkComparable x y = + case (x, y) of + (NVConstant (NFloat _), NVConstant (NInt _)) -> pure () + (NVConstant (NInt _), NVConstant (NFloat _)) -> pure () + (NVConstant (NInt _), NVConstant (NInt _)) -> pure () + (NVConstant (NFloat _), NVConstant (NFloat _)) -> pure () + (NVStr _ , NVStr _ ) -> pure () + (NVPath _ , NVPath _ ) -> pure () + _ -> throwError $ Comparison x y -- | Checks whether two containers are equal, using the given item equality -- predicate. If there are any item slots that don't match between the two @@ -52,45 +55,82 @@ alignEqM -> f a -> f b -> m Bool -alignEqM eq fa fb = fmap (either (const False) (const True)) $ runExceptT $ do - pairs <- forM (Data.Align.align fa fb) $ \case - These a b -> pure (a, b) - _ -> throwE () - for_ pairs $ \(a, b) -> guard =<< lift (eq a b) +alignEqM eq fa fb = + fmap + (either + (const False) + (const True) + ) + $ runExceptT $ + do + pairs <- + traverse + (\case + These a b -> pure (a, b) + _ -> throwE () + ) + (Data.Align.align fa fb) + traverse_ (\ (a, b) -> guard =<< lift (eq a b)) pairs alignEq :: (Align f, Traversable f) => (a -> b -> Bool) -> f a -> f b -> Bool alignEq eq fa fb = runIdentity $ alignEqM (\x y -> Identity (eq x y)) fa fb -isDerivationM :: Monad m => (t -> m (Maybe NixString)) -> AttrSet t -> m Bool -isDerivationM f m = case HashMap.Lazy.lookup "type" m of - Nothing -> pure False - Just t -> do - mres <- f t - case mres of - -- We should probably really make sure the context is empty here - -- but the C++ implementation ignores it. - Just s -> pure $ stringIgnoreContext s == "derivation" - Nothing -> pure False - -isDerivation :: Monad m => (t -> Maybe NixString) -> AttrSet t -> Bool +isDerivationM + :: Monad m + => ( t + -> m (Maybe NixString) + ) + -> AttrSet t + -> m Bool +isDerivationM f m = + maybe + (pure False) + (\ t -> + do + mres <- f t + + maybe + -- We should probably really make sure the context is empty here + -- but the C++ implementation ignores it. + (pure False) + (pure . (==) "derivation" . stringIgnoreContext) + mres + ) + (HashMap.Lazy.lookup "type" m) + +isDerivation + :: Monad m + => ( t + -> Maybe NixString + ) + -> AttrSet t + -> Bool isDerivation f = runIdentity . isDerivationM (Identity . f) valueFEqM :: Monad n - => (AttrSet a -> AttrSet a -> n Bool) - -> (a -> a -> n Bool) + => ( AttrSet a + -> AttrSet a + -> n Bool + ) + -> ( a + -> a + -> n Bool + ) -> NValueF p m a -> NValueF p m a -> n Bool -valueFEqM attrsEq eq = curry $ \case - (NVConstantF (NFloat x), NVConstantF (NInt y) ) -> pure $ x == fromInteger y - (NVConstantF (NInt x), NVConstantF (NFloat y)) -> pure $ fromInteger x == y - (NVConstantF lc , NVConstantF rc ) -> pure $ lc == rc - (NVStrF ls, NVStrF rs) -> pure $ (\i -> i ls == i rs) stringIgnoreContext - (NVListF ls , NVListF rs ) -> alignEqM eq ls rs - (NVSetF lm _, NVSetF rm _) -> attrsEq lm rm - (NVPathF lp , NVPathF rp ) -> pure $ lp == rp - _ -> pure False +valueFEqM attrsEq eq = + curry $ + \case + (NVConstantF (NFloat x), NVConstantF (NInt y)) -> pure $ x == fromInteger y + (NVConstantF (NInt x), NVConstantF (NFloat y)) -> pure $ fromInteger x == y + (NVConstantF lc , NVConstantF rc ) -> pure $ lc == rc + (NVStrF ls , NVStrF rs ) -> pure $ (\ i -> i ls == i rs) stringIgnoreContext + (NVListF ls , NVListF rs ) -> alignEqM eq ls rs + (NVSetF lm _ , NVSetF rm _ ) -> attrsEq lm rm + (NVPathF lp , NVPathF rp ) -> pure $ lp == rp + _ -> pure False valueFEq :: (AttrSet a -> AttrSet a -> Bool) @@ -98,11 +138,13 @@ valueFEq -> NValueF p m a -> NValueF p m a -> Bool -valueFEq attrsEq eq x y = runIdentity $ valueFEqM - (\x' y' -> Identity $ attrsEq x' y') - (\x' y' -> Identity $ eq x' y') - x - y +valueFEq attrsEq eq x y = + runIdentity $ + valueFEqM + (\x' y' -> Identity $ attrsEq x' y') + (\x' y' -> Identity $ eq x' y') + x + y compareAttrSetsM :: Monad m @@ -111,16 +153,24 @@ compareAttrSetsM -> AttrSet t -> AttrSet t -> m Bool -compareAttrSetsM f eq lm rm = do - isDerivationM f lm >>= \case - True -> isDerivationM f rm >>= \case - True - | Just lp <- HashMap.Lazy.lookup "outPath" lm, Just rp <- HashMap.Lazy.lookup "outPath" rm -> eq - lp - rp - _ -> compareAttrs - _ -> compareAttrs - where compareAttrs = alignEqM eq lm rm +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 + where + compareAttrs = alignEqM eq lm rm compareAttrSets :: (t -> Maybe NixString) @@ -138,29 +188,42 @@ valueEqM -> m Bool valueEqM ( Pure x) ( Pure y) = thunkEqM x y valueEqM ( Pure x) y@(Free _) = thunkEqM x =<< thunk (pure y) -valueEqM x@(Free _) ( Pure y) = thunkEqM ?? y =<< thunk (pure x) +valueEqM x@(Free _) ( Pure y) = (`thunkEqM` y) =<< thunk (pure x) valueEqM (Free (NValue (extract -> x))) (Free (NValue (extract -> y))) = - valueFEqM (compareAttrSetsM f valueEqM) valueEqM x y + valueFEqM + (compareAttrSetsM f valueEqM) + valueEqM + x + y where f = free - (pure . (\case + (pure . + (\case NVStr s -> pure s _ -> mempty ) <=< force ) - (pure . \case - NVStr' s -> pure s - _ -> mempty + (pure . + \case + NVStr' s -> pure s + _ -> mempty ) thunkEqM :: (MonadThunk t m (NValue t f m), Comonad f) => t -> t -> m Bool -thunkEqM lt rt = (=<< force lt) $ \lv -> (=<< force rt) $ \rv -> - let unsafePtrEq = case (lt, rt) of - (thunkId -> lid, thunkId -> rid) | lid == rid -> pure True - _ -> valueEqM lv rv - in case (lv, rv) of - (NVClosure _ _, NVClosure _ _) -> unsafePtrEq - (NVList _ , NVList _ ) -> unsafePtrEq - (NVSet _ _ , NVSet _ _ ) -> unsafePtrEq - _ -> valueEqM lv rv +thunkEqM lt rt = + do + lv <- force lt + rv <- force rt + + let + unsafePtrEq = + case (lt, rt) of + (thunkId -> lid, thunkId -> rid) | lid == rid -> pure True + _ -> valueEqM lv rv + + case (lv, rv) of + (NVClosure _ _, NVClosure _ _) -> unsafePtrEq + (NVList _ , NVList _ ) -> unsafePtrEq + (NVSet _ _ , NVSet _ _ ) -> unsafePtrEq + _ -> valueEqM lv rv