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

GHC 8.6 support

Browse source
This commit is contained in:
Domen Kožar 2018-10-27 12:37:02 +01:00
parent bf57d2d6eb
commit 58a83622eb
No known key found for this signature in database
GPG key ID: C2FFBCAFD2C24246
5 changed files with 28 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
main/Repl.hs
View file

@ -11,6 +11,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
@ -180,7 +181,13 @@ completer = Prefix (wordCompleter comp) defaultMatcher
shell :: (MonadNix e m, MonadIO m, MonadException m) => Repl e m a -> m ()
shell pre = flip evalStateT initState $
evalRepl "hnix> " cmd options completer pre
#if MIN_VERSION_repline(0, 2, 0)
evalRepl (return prefix() cmd options Nothing completer pre
#else
evalRepl prefix cmd options completer pre
#endif
where
prefix = "hnix> "
-------------------------------------------------------------------------------
-- Toplevel

12
src/Nix/Eval.hs
View file

@ -205,8 +205,12 @@ desugarBinds embed binds = evalState (mapM (go <=< collect) binds) M.empty
(Binding r)
go (Right x) = pure x
go (Left x) = do
Just (p, v) <- gets $ M.lookup x
pure $ NamedVar (StaticKey x :| []) (embed v) p
maybeValue <- gets (M.lookup x)
case maybeValue of
Nothing ->
fail ("No binding " ++ show x)
Just (p, v) ->
pure $ NamedVar (StaticKey x :| []) (embed v) p
evalBinds :: forall v t m. MonadNixEval v t m
=> Bool
@ -309,8 +313,8 @@ evalSetterKeyName :: (MonadEval v m, FromValue NixString m v)
=> NKeyName (m v) -> m (Maybe Text)
evalSetterKeyName = \case
StaticKey k -> pure (Just k)
DynamicKey k ->
runAntiquoted "\n" assembleString (>>= fromValueMay) k <&>
DynamicKey k ->
runAntiquoted "\n" assembleString (>>= fromValueMay) k <&>
\case Just ns -> Just (hackyStringIgnoreContext ns)
_ -> Nothing

4
src/Nix/Lint.hs
View file

@ -372,7 +372,7 @@ lintApp context fun arg = unpackSymbolic fun >>= \case
NAny -> throwError $ ErrorCall
"Cannot apply something not known to be a function"
NMany xs -> do
(args:_, ys) <- fmap unzip $ forM xs $ \case
(args, ys) <- fmap unzip $ forM xs $ \case
TClosure _params -> arg >>= unpackSymbolic >>= \case
NAny -> do
error "NYI"
@ -386,7 +386,7 @@ lintApp context fun arg = unpackSymbolic fun >>= \case
_x -> throwError $ ErrorCall "Attempt to call non-function"
y <- everyPossible
(args,) <$> foldM (unify context) y ys
(head args,) <$> foldM (unify context) y ys
newtype Lint s a = Lint
{ runLint :: ReaderT (Context (Lint s) (SThunk (Lint s))) (ST s) a }

14
src/Nix/Reduce.hs
View file

@ -35,6 +35,7 @@ import Control.Applicative
import Control.Arrow (second)
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Fail
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Reader
@ -67,13 +68,13 @@ newtype Reducer m a = Reducer
{ runReducer :: ReaderT (Maybe FilePath, Scopes (Reducer m) NExprLoc)
(StateT (HashMap FilePath NExprLoc) m) a }
deriving (Functor, Applicative, Alternative, Monad, MonadPlus,
MonadFix, MonadIO,
MonadFix, MonadIO, MonadFail,
MonadReader (Maybe FilePath, Scopes (Reducer m) NExprLoc),
MonadState (HashMap FilePath NExprLoc))
staticImport
:: forall m.
(MonadIO m, Scoped NExprLoc m,
(MonadIO m, Scoped NExprLoc m, MonadFail m,
MonadReader (Maybe FilePath, Scopes m NExprLoc) m,
MonadState (HashMap FilePath NExprLoc) m)
=> SrcSpan -> FilePath -> m NExprLoc
@ -111,7 +112,8 @@ staticImport pann path = do
-- NSym_ _ var -> S.singleton var
-- Compose (Ann _ x) -> fold x
reduceExpr :: MonadIO m => Maybe FilePath -> NExprLoc -> m NExprLoc
reduceExpr :: (MonadIO m, MonadFail m)
=> Maybe FilePath -> NExprLoc -> m NExprLoc
reduceExpr mpath expr
= (`evalStateT` M.empty)
. (`runReaderT` (mpath, emptyScopes))
@ -119,7 +121,7 @@ reduceExpr mpath expr
$ cata reduce expr
reduce :: forall m.
(MonadIO m, Scoped NExprLoc m,
(MonadIO m, Scoped NExprLoc m, MonadFail m,
MonadReader (Maybe FilePath, Scopes m NExprLoc) m,
MonadState (HashMap FilePath NExprLoc) m)
=> NExprLocF (m NExprLoc) -> m NExprLoc
@ -143,7 +145,7 @@ reduce (NUnary_ uann op arg) = arg >>= \x -> case (op, x) of
-- * Reduce an import to the actual imported expression.
--
-- * Reduce a lambda function by adding its name to the local
-- scope and recursively reducing its body.
-- scope and recursively reducing its body.
reduce (NBinary_ bann NApp fun arg) = fun >>= \case
f@(Fix (NSym_ _ "import")) -> arg >>= \case
-- Fix (NEnvPath_ pann origPath) -> staticImport pann origPath
@ -190,7 +192,7 @@ reduce base@(NSelect_ _ _ attrs _)
_ -> findBind xs attrs
-- Follow the attrpath recursively in sets.
inspectSet (NSet_ _ binds) attrs = case findBind binds attrs of
Just (NamedVar _ e _) -> case NE.uncons attrs of
Just (NamedVar _ e _) -> case NE.uncons attrs of
(_,Just attrs) -> inspectSet (unFix e) attrs
_ -> pure e
_ -> sId

3
src/Nix/Type/Infer.hs
View file

@ -27,6 +27,7 @@ import Control.Applicative
import Control.Arrow
import Control.Monad.Catch
import Control.Monad.Except
import Control.Monad.Fail
import Control.Monad.Logic
import Control.Monad.Reader
import Control.Monad.Ref
@ -68,7 +69,7 @@ newtype Infer s a = Infer
(StateT InferState (ExceptT InferError (ST s))) a
}
deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix,
MonadReader (Set.Set TVar, Scopes (Infer s) (JThunk s)),
MonadReader (Set.Set TVar, Scopes (Infer s) (JThunk s)), MonadFail,
MonadState InferState, MonadError InferError)
-- | Inference state