haskell-nix/hnix
1
1
Fork 0
mirror of https://github.com/haskell-nix/hnix.git synced 2024-09-21 03:38:25 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #281 from jwiegley/pending

Browse Source 
Pull request for pending
This commit is contained in:
John Wiegley 2018-05-02 13:21:02 -07:00 committed by GitHub
commit 2bb0a8c5fc
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
16 changed files with 431 additions and 347 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
hnix.cabal
View File

@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
-- hash: 07cd6a1b7913ff6635f99b4d896cdcbd096091580710fe2b350ebd5cedc52802
-- hash: 495fbcc0ec91c76bd2a6f9a571bca3014f7dd68489dc137eb17528a4dfde7a00
name: hnix
version: 0.5.0
@ -101,6 +101,7 @@ library
, filepath
, hashable
, haskeline
, logict
, megaparsec
, monadlist
, mtl

15
main/Main.hs
View File

@ -12,11 +12,13 @@ import qualified Control.Exception as Exc
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.ST
-- import Control.Monad.ST
import qualified Data.Aeson.Encoding as A
import qualified Data.Aeson.Text as A
import qualified Data.HashMap.Lazy as M
import qualified Data.Map as Map
import Data.List (sortOn)
import Data.Maybe (fromJust)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.Text.Lazy.Encoding as TL
@ -24,7 +26,7 @@ import qualified Data.Text.Lazy.IO as TL
import Nix
import Nix.Convert
import qualified Nix.Eval as Eval
import Nix.Lint
-- import Nix.Lint
import qualified Nix.Type.Env as Env
import qualified Nix.Type.Infer as HM
import Nix.Utils
@ -73,12 +75,13 @@ main = do
when (check opts) $ do
case HM.inferTop Env.empty [("it", stripAnnotation expr)] of
Left err ->
errorWithoutStackTrace $ "Type error: " ++ show err
errorWithoutStackTrace $ "Type error: " ++ PS.ppShow err
Right ty ->
liftIO $ putStrLn $ "Type of expression: " ++ PS.ppShow ty
liftIO $ putStrLn $ "Type of expression: "
++ PS.ppShow (fromJust (Map.lookup "it" (Env.types ty)))
liftIO $ putStrLn $ runST $
runLintM opts . renderSymbolic =<< lint opts expr
-- liftIO $ putStrLn $ runST $
-- runLintM opts . renderSymbolic =<< lint opts expr
catch (process opts mpath expr) $ \case
NixException frames ->

1
package.yaml
View File

@ -74,6 +74,7 @@ library:
- directory
- hashable
- haskeline
- logict
- megaparsec
- monadlist
- pretty-show

109
src/Nix/Builtins.hs
View File

@ -111,7 +111,7 @@ builtinsList = sequence [
, add0 Normal "nixPath" nixPath
, add TopLevel "abort" throw_ -- for now
, add2 Normal "add" add_
, add2 Normal "add" add_
, add2 Normal "all" all_
, add2 Normal "any" any_
, add Normal "attrNames" attrNames
@ -201,7 +201,8 @@ builtinsList = sequence [
arity1 f = Prim . pure . f
arity2 f = ((Prim . pure) .) . f
mkThunk n = thunk . withFrame Info ("While calling builtin " ++ Text.unpack n ++ "\n")
mkThunk n = thunk . withFrame Info
(ErrorCall $ "While calling builtin " ++ Text.unpack n ++ "\n")
add0 t n v = wrap t n <$> mkThunk n v
add t n v = wrap t n <$> mkThunk n (builtin (Text.unpack n) v)
@ -228,7 +229,7 @@ foldNixPath f z = do
go x rest = case Text.splitOn "=" x of
[p] -> f (Text.unpack p) Nothing rest
[n, p] -> f (Text.unpack p) (Just (Text.unpack n)) rest
_ -> throwError @String $ "Unexpected entry in NIX_PATH: " ++ show x
_ -> throwError $ ErrorCall $ "Unexpected entry in NIX_PATH: " ++ show x
nixPath :: MonadNix e m => m (NValue m)
nixPath = fmap nvList $ flip foldNixPath [] $ \p mn rest ->
@ -242,23 +243,22 @@ toString :: MonadNix e m => m (NValue m) -> m (NValue m)
toString str =
str >>= normalForm >>= valueText False >>= toNix @(Text, DList Text)
hasAttr :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
hasAttr x y = x >>= \x' -> y >>= \y' -> case (x', y') of
(NVStr key _, NVSet aset _) ->
return . nvConstant . NBool $ M.member key aset
(x, y) -> throwError @String $ "Invalid types for builtin.hasAttr: "
++ show (x, y)
hasAttr :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
hasAttr x y =
fromValue @Text x >>= \key ->
fromValue @(AttrSet (NThunk m), AttrSet SourcePos) y >>= \(aset, _) ->
toNix $ M.member key aset
attrsetGet :: MonadNix e m => Text -> AttrSet t -> m t
attrsetGet k s = case M.lookup k s of
Just v -> pure v
Nothing ->
throwError ("Attribute '" ++ Text.unpack k ++ "' required" :: String)
throwError $ ErrorCall $ "Attribute '" ++ Text.unpack k ++ "' required"
getAttr :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
getAttr x y = x >>= \x' -> y >>= \y' -> case (x', y') of
(NVStr key _, NVSet aset _) -> attrsetGet key aset >>= force'
(x, y) -> throwError @String $ "Invalid types for builtin.getAttr: "
(x, y) -> throwError $ ErrorCall $ "Invalid types for builtin.getAttr: "
++ show (x, y)
unsafeGetAttrPos :: forall e m. MonadNix e m
@ -266,10 +266,10 @@ unsafeGetAttrPos :: forall e m. MonadNix e m
unsafeGetAttrPos x y = x >>= \x' -> y >>= \y' -> case (x', y') of
(NVStr key _, NVSet _ apos) -> case M.lookup key apos of
Nothing ->
throwError @String $ "unsafeGetAttrPos: field '" ++ Text.unpack key
throwError $ ErrorCall $ "unsafeGetAttrPos: field '" ++ Text.unpack key
++ "' does not exist in attr set: " ++ show apos
Just delta -> toValue delta
(x, y) -> throwError @String $ "Invalid types for builtin.unsafeGetAttrPos: "
(x, y) -> throwError $ ErrorCall $ "Invalid types for builtin.unsafeGetAttrPos: "
++ show (x, y)
-- This function is a bit special in that it doesn't care about the contents
@ -340,12 +340,12 @@ foldl'_ fun z xs =
head_ :: MonadNix e m => m (NValue m) -> m (NValue m)
head_ = fromValue >=> \case
[] -> throwError @String "builtins.head: empty list"
[] -> throwError $ ErrorCall "builtins.head: empty list"
h:_ -> force' h
tail_ :: MonadNix e m => m (NValue m) -> m (NValue m)
tail_ = fromValue >=> \case
[] -> throwError @String "builtins.tail: empty list"
[] -> throwError $ ErrorCall "builtins.tail: empty list"
_:t -> return $ nvList t
data VersionComponent
@ -470,7 +470,7 @@ thunkStr s = valueThunk (nvStr (decodeUtf8 s) mempty)
substring :: MonadNix e m => Int -> Int -> Text -> Prim m Text
substring start len str = Prim $
if start < 0 --NOTE: negative values of 'len' are OK
then throwError @String $ "builtins.substring: negative start position: " ++ show start
then throwError $ ErrorCall $ "builtins.substring: negative start position: " ++ show start
else pure $ Text.take len $ Text.drop start str
attrNames :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
@ -483,7 +483,8 @@ attrValues = fromValue @(ValueSet m) >=>
map_ :: forall e m. MonadNix e m
=> m (NValue m) -> m (NValue m) -> m (NValue m)
map_ fun xs = fun >>= \f ->
toNix <=< traverse (thunk . withFrame @String Debug "While applying f in map:\n"
toNix <=< traverse (thunk . withFrame Debug
(ErrorCall "While applying f in map:\n")
. (f `callFunc`) . force')
<=< fromValue @[NThunk m] $ xs
@ -503,13 +504,13 @@ baseNameOf :: MonadNix e m => m (NValue m) -> m (NValue m)
baseNameOf x = x >>= \case
NVStr path ctx -> pure $ nvStr (Text.pack $ takeFileName $ Text.unpack path) ctx
NVPath path -> pure $ nvPath $ takeFileName path
v -> throwError @String $ "dirOf: expected string or path, got " ++ show v
v -> throwError $ ErrorCall $ "dirOf: expected string or path, got " ++ show v
dirOf :: MonadNix e m => m (NValue m) -> m (NValue m)
dirOf x = x >>= \case
NVStr path ctx -> pure $ nvStr (Text.pack $ takeDirectory $ Text.unpack path) ctx
NVPath path -> pure $ nvPath $ takeDirectory path
v -> throwError @String $ "dirOf: expected string or path, got " ++ show v
v -> throwError $ ErrorCall $ "dirOf: expected string or path, got " ++ show v
-- jww (2018-04-28): This should only be a string argument, and not coerced?
unsafeDiscardStringContext :: MonadNix e m => m (NValue m) -> m (NValue m)
@ -542,7 +543,7 @@ elemAt_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
elemAt_ xs n = fromValue n >>= \n' -> fromValue xs >>= \xs' ->
case elemAt xs' n' of
Just a -> force' a
Nothing -> throwError @String $ "builtins.elem: Index " ++ show n'
Nothing -> throwError $ ErrorCall $ "builtins.elem: Index " ++ show n'
++ " too large for list of length " ++ show (length xs')
genList :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
@ -550,24 +551,22 @@ genList generator = fromValue @Integer >=> \n ->
if n >= 0
then generator >>= \f ->
toNix =<< forM [0 .. n - 1] (\i -> thunk $ f `callFunc` toNix i)
else throwError @String $ "builtins.genList: Expected a non-negative number, got "
else throwError $ ErrorCall $ "builtins.genList: Expected a non-negative number, got "
++ show n
genericClosure :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
genericClosure = fromValue @(AttrSet (NThunk m)) >=> \s ->
case (M.lookup "startSet" s, M.lookup "operator" s) of
(Nothing, Nothing) ->
throwError
("builtins.genericClosure: Attributes 'startSet' and 'operator' required"
:: String)
throwError $ ErrorCall $
"builtins.genericClosure: "
++ "Attributes 'startSet' and 'operator' required"
(Nothing, Just _) ->
throwError
("builtins.genericClosure: Attribute 'startSet' required"
:: String)
throwError $ ErrorCall $
"builtins.genericClosure: Attribute 'startSet' required"
(Just _, Nothing) ->
throwError
("builtins.genericClosure: Attribute 'operator' required"
:: String)
throwError $ ErrorCall $
"builtins.genericClosure: Attribute 'operator' required"
(Just startSet, Just operator) ->
fromValue @[NThunk m] startSet >>= \ss ->
force operator $ \op ->
@ -580,8 +579,8 @@ genericClosure = fromValue @(AttrSet (NThunk m)) >=> \s ->
force t $ \v -> fromValue @(AttrSet (NThunk m)) t >>= \s ->
case M.lookup "key" s of
Nothing ->
throwError
("builtins.genericClosure: Attribute 'key' required" :: String)
throwError $ ErrorCall $
"builtins.genericClosure: Attribute 'key' required"
Just k -> force k $ \k' ->
if S.member k' ks
then go op ts ks
@ -598,8 +597,9 @@ replaceStrings tfrom tto ts =
fromNix tto >>= \(to :: [Text]) ->
fromValue ts >>= \(s :: Text) -> do
when (length from /= length to) $
throwError @String $ "'from' and 'to' arguments to 'replaceStrings'"
++ " have different lengths"
throwError $ ErrorCall $
"'from' and 'to' arguments to 'replaceStrings'"
++ " have different lengths"
let lookupPrefix s = do
(prefix, replacement) <-
find ((`Text.isPrefixOf` s) . fst) $ zip from to
@ -646,8 +646,8 @@ functionArgs fun = fun >>= \case
case p of
Param name -> M.singleton name False
ParamSet s _ _ -> isJust <$> M.fromList s
v -> throwError @String $ "builtins.functionArgs: expected function, got "
++ show v
v -> throwError $ ErrorCall $
"builtins.functionArgs: expected function, got " ++ show v
toPath :: MonadNix e m => m (NValue m) -> m (NValue m)
toPath = fromValue @Path >=> toNix @Path
@ -656,7 +656,8 @@ pathExists_ :: MonadNix e m => m (NValue m) -> m (NValue m)
pathExists_ path = path >>= \case
NVPath p -> toNix =<< pathExists p
NVStr s _ -> toNix =<< pathExists (Text.unpack s)
v -> throwError @String $ "builtins.pathExists: expected path, got " ++ show v
v -> throwError $ ErrorCall $
"builtins.pathExists: expected path, got " ++ show v
hasKind :: forall a e m. (MonadNix e m, FromValue a m (NValue m))
=> m (NValue m) -> m (NValue m)
@ -689,7 +690,7 @@ isFunction func = func >>= \case
_ -> toValue False
throw_ :: MonadNix e m => m (NValue m) -> m (NValue m)
throw_ = fromValue >=> throwError . Text.unpack
throw_ = fromValue >=> throwError . ErrorCall . Text.unpack
import_ :: MonadNix e m => m (NValue m) -> m (NValue m)
import_ = fromValue >=> importPath M.empty . getPath
@ -723,8 +724,9 @@ sort_ comparator xs = comparator >>= \comp ->
lessThan :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
lessThan ta tb = ta >>= \va -> tb >>= \vb -> do
let badType = throwError @String $ "builtins.lessThan: expected two numbers or two strings, "
++ "got " ++ show va ++ " and " ++ show vb
let badType = throwError $ ErrorCall $
"builtins.lessThan: expected two numbers or two strings, "
++ "got " ++ show va ++ " and " ++ show vb
nvConstant . NBool <$> case (va, vb) of
(NVConstant ca, NVConstant cb) -> case (ca, cb) of
(NInt a, NInt b) -> pure $ a < b
@ -746,7 +748,10 @@ listToAttrs = fromValue @[NThunk m] >=> \l ->
forM l $ fromValue @(AttrSet (NThunk m)) >=> \s ->
case (M.lookup "name" s, M.lookup "value" s) of
(Just name, Just value) -> fromValue name <&> (, value)
_ -> throwError $
_ -> throwError $ ErrorCall $
-- jww (2018-05-01): Rather than include the function name
-- in the message like this, we should add it as a frame
-- in `callFunc' before calling each builtin.
"builtins.listToAttrs: expected set with name and value, got"
++ show s
@ -757,7 +762,7 @@ hashString algo s = Prim $ do
"sha1" -> pure SHA1.hash
"sha256" -> pure SHA256.hash
"sha512" -> pure SHA512.hash
_ -> throwError @String $ "builtins.hashString: "
_ -> throwError $ ErrorCall $ "builtins.hashString: "
++ "expected \"md5\", \"sha1\", \"sha256\", or \"sha512\", got " ++ show algo
pure $ decodeUtf8 $ Base16.encode $ hash $ encodeUtf8 s
@ -766,10 +771,10 @@ absolutePathFromValue = \case
NVStr pathText _ -> do
let path = Text.unpack pathText
unless (isAbsolute path) $
throwError @String $ "string " ++ show path ++ " doesn't represent an absolute path"
throwError $ ErrorCall $ "string " ++ show path ++ " doesn't represent an absolute path"
pure path
NVPath path -> pure path
v -> throwError @String $ "expected a path, got " ++ show v
v -> throwError $ ErrorCall $ "expected a path, got " ++ show v
readFile_ :: MonadNix e m => m (NValue m) -> m (NValue m)
readFile_ path =
@ -806,7 +811,8 @@ readDir_ pathThunk = do
fromJSON :: MonadNix e m => m (NValue m) -> m (NValue m)
fromJSON = fromValue >=> \encoded ->
case A.eitherDecodeStrict' @A.Value $ encodeUtf8 encoded of
Left jsonError -> throwError @String $ "builtins.fromJSON: " ++ jsonError
Left jsonError ->
throwError $ ErrorCall $ "builtins.fromJSON: " ++ jsonError
Right v -> toValue v
toXML_ :: MonadNix e m => m (NValue m) -> m (NValue m)
@ -846,19 +852,20 @@ tryEval e = catch (onSuccess <$> e) (pure . onError)
fetchTarball :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
fetchTarball v = v >>= \case
NVSet s _ -> case M.lookup "url" s of
Nothing -> throwError @String "builtins.fetchTarball: Missing url attribute"
Nothing -> throwError $ ErrorCall
"builtins.fetchTarball: Missing url attribute"
Just url -> force url $ go (M.lookup "sha256" s)
v@NVStr {} -> go Nothing v
v@(NVConstant (NUri _)) -> go Nothing v
v -> throwError @String $ "builtins.fetchTarball: Expected URI or set, got "
++ show v
v -> throwError $ ErrorCall $
"builtins.fetchTarball: Expected URI or set, got " ++ show v
where
go :: Maybe (NThunk m) -> NValue m -> m (NValue m)
go msha = \case
NVStr uri _ -> fetch uri msha
NVConstant (NUri uri) -> fetch uri msha
v -> throwError @String $ "builtins.fetchTarball: Expected URI or string, got "
++ show v
v -> throwError $ ErrorCall $
"builtins.fetchTarball: Expected URI or string, got " ++ show v
{- jww (2018-04-11): This should be written using pipes in another module
fetch :: Text -> Maybe (NThunk m) -> m (NValue m)
@ -868,7 +875,7 @@ fetchTarball v = v >>= \case
".bz2" -> undefined
".xz" -> undefined
".tar" -> undefined
ext -> throwError @String $ "builtins.fetchTarball: Unsupported extension '"
ext -> throwError $ ErrorCall $ "builtins.fetchTarball: Unsupported extension '"
++ ext ++ "'"
-}

2
src/Nix/Convert.hs
View File

@ -440,7 +440,7 @@ instance Applicative m => ToValue Bool m (NExprF r) where
instance Applicative m => ToValue () m (NExprF r) where
toValue _ = pure . NConstant $ NNull
whileForcingThunk :: forall s e m r. (Framed e m, Frame s, Typeable m)
whileForcingThunk :: forall s e m r. (Framed e m, Exception s, Typeable m)
=> s -> m r -> m r
whileForcingThunk frame =
withFrame Debug (ForcingThunk @m) . withFrame Debug frame

31
src/Nix/Eval.hs
View File

@ -36,7 +36,6 @@ import Data.Text (Text)
import qualified Data.Text as Text
import Data.These
import Data.Traversable (for)
import Data.Void
import Nix.Atoms
import Nix.Convert
import Nix.Expr
@ -63,7 +62,7 @@ class (Show v, Monad m) => MonadEval v m | v -> m where
evalIf :: v -> m v -> m v -> m v
evalAssert :: v -> m v -> m v
evalApp :: v -> m v -> m v
evalAbs :: Params Void -> (m v -> m v) -> m v
evalAbs :: Params (m v) -> (m v -> m v) -> m v
{-
evalSelect :: v -> NonEmpty Text -> Maybe (m v) -> m v
@ -81,7 +80,7 @@ class (Show v, Monad m) => MonadEval v m | v -> m where
evalLet :: m v -> m v
-}
evalError :: Frame s => s -> m a
evalError :: Exception s => s -> m a
type MonadNixEval e v t m =
(MonadEval v m,
@ -99,7 +98,7 @@ data EvalFrame m v
| ForcingExpr (Scopes m v) NExprLoc
deriving (Show, Typeable)
instance (Typeable m, Typeable v) => Frame (EvalFrame m v)
instance (Typeable m, Typeable v) => Exception (EvalFrame m v)
eval :: forall e v t m. MonadNixEval e v t m => NExprF (m v) -> m v
@ -128,7 +127,7 @@ eval (NSelect aset attr alt) = do
Right v -> v
Left (s, ks) -> fromMaybe err alt
where
err = evalError @v $ "Could not look up attribute "
err = evalError @v $ ErrorCall $ "Could not look up attribute "
++ intercalate "." (map Text.unpack (NE.toList ks))
++ " in " ++ show @v s
@ -171,14 +170,10 @@ eval (NAbs params body) = do
-- we defer here so the present scope is restored when the parameters and
-- body are forced during application.
scope <- currentScopes @_ @t
evalAbs (clearDefaults params) $ \arg ->
evalAbs params $ \arg ->
withScopes @t scope $ do
args <- buildArgument params arg
pushScope args body
where
clearDefaults :: Params r -> Params Void
clearDefaults (Param name) = Param name
clearDefaults (ParamSet xs b mv) = ParamSet (map (Nothing <$) xs) b mv
-- | If you know that the 'scope' action will result in an 'AttrSet t', then
-- this implementation may be used as an implementation for 'evalWith'.
@ -199,7 +194,7 @@ attrSetAlter :: forall e v t m. MonadNixEval e v t m
-> m v
-> m (AttrSet (m v))
attrSetAlter [] _ _ =
evalError @v ("invalid selector with no components" :: String)
evalError @v $ ErrorCall "invalid selector with no components"
attrSetAlter (p:ps) m val = case M.lookup p m of
Nothing
| null ps -> go
@ -289,8 +284,8 @@ evalBinds allowDynamic recursive binds = do
>>= \(s, _) ->
clearScopes @t $ pushScope s $ lookupVar key
case mv of
Nothing -> evalError @v $ "Inheriting unknown attribute: "
++ show (void name)
Nothing -> evalError @v $ ErrorCall $
"Inheriting unknown attribute: " ++ show (void name)
Just v -> force v pure)
buildResult :: Scopes m t
@ -356,14 +351,14 @@ evalKeyNameStatic :: forall v m. MonadEval v m
evalKeyNameStatic = \case
StaticKey k p -> pure (k, p)
DynamicKey _ ->
evalError @v ("dynamic attribute not allowed in this context" :: String)
evalError @v $ ErrorCall "dynamic attribute not allowed in this context"
evalKeyNameDynamicNotNull
:: forall v m. (MonadEval v m, FromValue (Text, DList Text) m v)
=> NKeyName (m v) -> m (Text, Maybe SourcePos)
evalKeyNameDynamicNotNull = evalKeyNameDynamicNullable >=> \case
(Nothing, _) ->
evalError @v ("value is null while a string was expected" :: String)
evalError @v $ ErrorCall "value is null while a string was expected"
(Just k, p) -> pure (k, p)
-- | Evaluate a component of an attribute path in a context where we are
@ -421,12 +416,14 @@ buildArgument params arg = do
-> m t
assemble scope isVariadic k = \case
That Nothing ->
const $ evalError @v $ "Missing value for parameter: " ++ show k
const $ evalError @v $ ErrorCall $
"Missing value for parameter: " ++ show k
That (Just f) -> \args ->
thunk $ withScopes scope $ pushScope args f
This x | isVariadic -> const (pure x)
| otherwise ->
const $ evalError @v $ "Unexpected parameter: " ++ show k
const $ evalError @v $ ErrorCall $
"Unexpected parameter: " ++ show k
These x _ -> const (pure x)
addSourcePositions :: (MonadReader e m, Has e SrcSpan)

99
src/Nix/Exec.hs
View File

@ -46,7 +46,6 @@ import Data.List.Split
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable
import Data.Void
import Nix.Atoms
import Nix.Context
import Nix.Convert
@ -88,9 +87,9 @@ type MonadNix e m =
data ExecFrame m = Assertion SrcSpan (NValue m)
deriving (Show, Typeable)
instance Typeable m => Frame (ExecFrame m)
instance Typeable m => Exception (ExecFrame m)
nverr :: forall s e m a. (MonadNix e m, Frame s) => s -> m a
nverr :: forall s e m a. (MonadNix e m, Exception s) => s -> m a
nverr = evalError @(NValue m)
currentPos :: forall e m. (MonadReader e m, Has e SrcSpan) => m SrcSpan
@ -109,8 +108,9 @@ instance MonadNix e m => MonadThunk (NValue m) (NThunk m) m where
-- Gather the current evaluation context at the time of thunk
-- creation, and record it along with the thunk.
let go (fromFrame -> Just (EvaluatingExpr scope
(Fix (Compose (Ann span e))))) =
let go (fromException ->
Just (EvaluatingExpr scope
(Fix (Compose (Ann span e))))) =
let e' = Compose (Ann span (Nothing <$ e))
in [Provenance scope e']
go _ = []
@ -120,11 +120,17 @@ instance MonadNix e m => MonadThunk (NValue m) (NThunk m) m where
else
fmap (NThunk [] . coerce) . buildThunk $ mv
force (NThunk ps t) f = case ps of
[] -> forceThunk t f
Provenance scope e@(Compose (Ann span _)):_ ->
withFrame Info (ForcingExpr scope (wrapExprLoc span e))
(forceThunk t f)
-- The ThunkLoop exception is thrown as an exception with MonadThrow,
-- which does not capture the current stack frame information to provide
-- it in a NixException, so we catch and re-throw it here using
-- 'throwError' from Frames.hs.
force (NThunk ps t) f = catch go (throwError @ThunkLoop)
where
go = case ps of
[] -> forceThunk t f
Provenance scope e@(Compose (Ann span _)):_ ->
withFrame Info (ForcingExpr scope (wrapExprLoc span e))
(forceThunk t f)
value = NThunk [] . coerce . valueRef
@ -140,7 +146,7 @@ prov p v = do
instance MonadNix e m => MonadEval (NValue m) m where
freeVariable var =
nverr $ "Undefined variable '" ++ Text.unpack var ++ "'"
nverr $ ErrorCall $ "Undefined variable '" ++ Text.unpack var ++ "'"
evalCurPos = do
scope <- currentScopes
@ -164,7 +170,7 @@ instance MonadNix e m => MonadEval (NValue m) m where
span <- currentPos
pure $ nvStrP (Provenance scope
(NStr_ span (DoubleQuoted [Plain s]))) s c
Nothing -> nverr ("Failed to assemble string" :: String)
Nothing -> nverr $ ErrorCall $ "Failed to assemble string"
evalLiteralPath p = do
scope <- currentScopes
@ -217,7 +223,7 @@ instance MonadNix e m => MonadEval (NValue m) m where
evalAbs p b = do
scope <- currentScopes
span <- currentPos
pure $ nvClosureP (Provenance scope (NAbs_ span (fmap absurd p) Nothing)) p b
pure $ nvClosureP (Provenance scope (NAbs_ span (Nothing <$ p) Nothing)) (void p) b
evalError = throwError
@ -233,7 +239,7 @@ callFunc fun arg = case fun of
s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do
traceM "callFunc:__functor"
force f $ (`callFunc` pure s) >=> (`callFunc` arg)
x -> throwError $ "Attempt to call non-function: " ++ show x
x -> throwError $ ErrorCall $ "Attempt to call non-function: " ++ show x
execUnaryOp :: (Framed e m, MonadVar m)
=> Scopes m (NThunk m) -> SrcSpan -> NUnaryOp -> NValue m
@ -245,9 +251,9 @@ execUnaryOp scope span op arg = do
(NNeg, NInt i) -> unaryOp $ NInt (-i)
(NNeg, NFloat f) -> unaryOp $ NFloat (-f)
(NNot, NBool b) -> unaryOp $ NBool (not b)
_ -> throwError $ "unsupported argument type for unary operator "
++ show op
x -> throwError $ "argument to unary operator"
_ -> 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
where
unaryOp = pure . nvConstantP (Provenance scope (NUnary_ span op (Just arg)))
@ -291,16 +297,16 @@ execBinaryOp scope span op lval rarg = do
(NGt, l, r) -> toBool $ l > r
(NGte, l, r) -> toBool $ l >= r
(NAnd, _, _) ->
nverr @String "should be impossible: && is handled above"
nverr $ ErrorCall "should be impossible: && is handled above"
(NOr, _, _) ->
nverr @String "should be impossible: || is handled above"
nverr $ ErrorCall "should be impossible: || is handled above"
(NPlus, l, r) -> numBinOp bin (+) l r
(NMinus, l, r) -> numBinOp bin (-) l r
(NMult, l, r) -> numBinOp bin (*) l r
(NDiv, l, r) -> numBinOp' bin div (/) l r
(NImpl,
NBool l, NBool r) -> toBool $ not l || r
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVStr ls lc, NVStr rs rc) -> case op of
NPlus -> pure $ bin nvStrP (ls `mappend` rs) (lc `mappend` rc)
@ -310,68 +316,68 @@ execBinaryOp scope span op lval rarg = do
NLte -> toBool $ ls <= rs
NGt -> toBool $ ls > rs
NGte -> toBool $ ls >= rs
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVStr _ _, NVConstant NNull) -> case op of
NEq -> toBool =<< valueEq lval (nvStr "" mempty)
NNEq -> toBool . not =<< valueEq lval (nvStr "" mempty)
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVConstant NNull, NVStr _ _) -> case op of
NEq -> toBool =<< valueEq (nvStr "" mempty) rval
NNEq -> toBool . not =<< valueEq (nvStr "" mempty) rval
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVSet ls lp, NVSet rs rp) -> case op of
NUpdate -> pure $ bin nvSetP (rs `M.union` ls) (rp `M.union` lp)
NEq -> toBool =<< valueEq lval rval
NNEq -> toBool . not =<< valueEq lval rval
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVSet ls lp, NVConstant NNull) -> case op of
NUpdate -> pure $ bin nvSetP ls lp
NEq -> toBool =<< valueEq lval (nvSet M.empty M.empty)
NNEq -> toBool . not =<< valueEq lval (nvSet M.empty M.empty)
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVConstant NNull, NVSet rs rp) -> case op of
NUpdate -> pure $ bin nvSetP rs rp
NEq -> toBool =<< valueEq (nvSet M.empty M.empty) rval
NNEq -> toBool . not =<< valueEq (nvSet M.empty M.empty) rval
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVList ls, NVList rs) -> case op of
NConcat -> pure $ bin nvListP $ ls ++ rs
NEq -> toBool =<< valueEq lval rval
NNEq -> toBool . not =<< valueEq lval rval
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVList ls, NVConstant NNull) -> case op of
NConcat -> pure $ bin nvListP ls
NEq -> toBool =<< valueEq lval (nvList [])
NNEq -> toBool . not =<< valueEq lval (nvList [])
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVConstant NNull, NVList rs) -> case op of
NConcat -> pure $ bin nvListP rs
NEq -> toBool =<< valueEq (nvList []) rval
NNEq -> toBool . not =<< valueEq (nvList []) rval
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVPath p, NVStr s _) -> case op of
NEq -> toBool $ p == Text.unpack s
NNEq -> toBool $ p /= Text.unpack s
NPlus -> bin nvPathP <$> makeAbsolutePath (p `mappend` Text.unpack s)
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVPath ls, NVPath rs) -> case op of
NPlus -> bin nvPathP <$> makeAbsolutePath (ls ++ rs)
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
_ -> case op of
NEq -> toBool False
NNEq -> toBool True
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
where
unsupportedTypes :: Show a => a -> a -> String
unsupportedTypes lval rval =
@ -391,7 +397,7 @@ execBinaryOp scope span op lval rarg = do
(NInt li, NFloat rf) -> toFloat $ fromInteger li `floatF` rf
(NFloat lf, NInt ri) -> toFloat $ lf `floatF` fromInteger ri
(NFloat lf, NFloat rf) -> toFloat $ lf `floatF` rf
_ -> nverr $ unsupportedTypes l r
_ -> nverr $ ErrorCall $ unsupportedTypes l r
where
toInt = pure . bin nvConstantP . NInt
toFloat = pure . bin nvConstantP . NFloat
@ -416,7 +422,7 @@ coerceToString = \case
NVSet s _ | Just p <- M.lookup "outPath" s ->
force p coerceToString
v -> throwError $ "Expected a string, but saw: " ++ show v
v -> throwError $ ErrorCall $ "Expected a string, but saw: " ++ show v
newtype Lazy m a = Lazy
{ runLazy :: ReaderT (Context (Lazy m) (NThunk (Lazy m)))
@ -448,8 +454,8 @@ instance MonadException m => MonadException (Lazy m) where
let run' = RunIO (fmap Lazy . run . runLazy)
in runLazy <$> f run'
instance (MonadFix m, MonadCatch m, MonadThrow m, MonadIO m,
Alternative m, MonadPlus m, Typeable m)
instance (MonadFix m, MonadCatch m, MonadIO m, Alternative m,
MonadPlus m, Typeable m)
=> MonadEffects (Lazy m) where
addPath path = do
(exitCode, out, _) <-
@ -458,7 +464,8 @@ instance (MonadFix m, MonadCatch m, MonadThrow m, MonadIO m,
ExitSuccess -> do
let dropTrailingLinefeed p = take (length p - 1) p
return $ StorePath $ dropTrailingLinefeed out
_ -> throwError $ "addPath: failed: nix-store --add " ++ show path
_ -> throwError $ ErrorCall $
"addPath: failed: nix-store --add " ++ show path
makeAbsolutePath origPath = do
origPathExpanded <- liftIO $ expandHomePath origPath
@ -469,7 +476,7 @@ instance (MonadFix m, MonadCatch m, MonadThrow m, MonadIO m,
Nothing -> liftIO getCurrentDirectory
Just v -> force v $ \case
NVPath s -> return $ takeDirectory s
v -> throwError $ "when resolving relative path,"
v -> throwError $ ErrorCall $ "when resolving relative path,"
++ " __cur_file is in scope,"
++ " but is not a path; it is: "
++ show v
@ -493,7 +500,7 @@ instance (MonadFix m, MonadCatch m, MonadThrow m, MonadIO m,
return $ takeDirectory p' </> path
traceM $ "Importing file " ++ path'
withFrame Info ("While importing file " ++ show path') $ do
withFrame Info (ErrorCall $ "While importing file " ++ show path') $ do
imports <- Lazy $ ReaderT $ const get
expr <- case M.lookup path' imports of
Just expr -> pure expr
@ -501,8 +508,8 @@ instance (MonadFix m, MonadCatch m, MonadThrow m, MonadIO m,
eres <- Lazy $ parseNixFileLoc path'
case eres of
Failure err ->
throwError $ text "Parse during import failed:"
P.</> err
throwError $ ErrorCall . show $
text "Parse during import failed:" P.</> err
Success expr -> do
Lazy $ ReaderT $ const $
modify (M.insert origPath expr)
@ -557,11 +564,11 @@ instance (MonadFix m, MonadCatch m, MonadThrow m, MonadIO m,
case exitCode of
ExitSuccess -> case parseNixTextLoc (Text.pack out) of
Failure err ->
throwError $ "Error parsing output of nix-instantiate: "
++ show err
throwError $ ErrorCall $
"Error parsing output of nix-instantiate: " ++ show err
Success v -> evalExprLoc v
status ->
throwError $ "nix-instantiate failed: " ++ show status
throwError $ ErrorCall $ "nix-instantiate failed: " ++ show status
++ ": " ++ err
getRecursiveSize =
@ -629,7 +636,7 @@ findEnvPathM name = do
foldM go Nothing l
case mpath of
Nothing ->
throwError $ "file '" ++ name
throwError $ ErrorCall $ "file '" ++ name
++ "' was not found in the Nix search path"
++ " (add it using $NIX_PATH or -I)"
Just path -> return path
@ -646,7 +653,7 @@ findEnvPathM name = do
tryPath path (Just (Text.unpack pfx))
_ -> tryPath path Nothing
Nothing ->
throwError $ "__nixPath must be a list of attr sets"
throwError $ ErrorCall $ "__nixPath must be a list of attr sets"
++ " with 'path' elements, but saw: " ++ show s
tryPath p (Just n) | n':ns <- splitDirectories name, n == n' =

30
src/Nix/Frames.hs
View File

@ -4,8 +4,8 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Nix.Frames (NixLevel(..), Frames, Framed, Frame(..), NixFrame(..),
NixException(..), SomeFrame(..), withFrame, throwError,
module Nix.Frames (NixLevel(..), Frames, Framed, NixFrame(..),
NixException(..), withFrame, throwError,
module Data.Typeable,
module Control.Exception) where
@ -14,29 +14,13 @@ import Control.Monad.Catch
import Control.Monad.Reader
import Data.Typeable hiding (typeOf)
import Nix.Utils
import Text.PrettyPrint.ANSI.Leijen (Doc)
data NixLevel = Fatal | Error | Warning | Info | Debug
deriving (Ord, Eq, Bounded, Enum, Show)
data SomeFrame = forall e. Frame e => SomeFrame e
instance Show SomeFrame where
show (SomeFrame f) = show f
class (Typeable e, Show e) => Frame e where
toFrame :: e -> SomeFrame
fromFrame :: SomeFrame -> Maybe e
toFrame = SomeFrame
fromFrame (SomeFrame e) = cast e
instance Frame [Char]
instance Frame Doc
data NixFrame = NixFrame
{ frameLevel :: NixLevel
, frame :: SomeFrame
, frame :: SomeException
}
instance Show NixFrame where
@ -52,11 +36,11 @@ newtype NixException = NixException Frames
instance Exception NixException
withFrame :: forall s e m a. (Framed e m, Frame s) => NixLevel -> s -> m a -> m a
withFrame level f = local (over hasLens (NixFrame level (toFrame f) :))
withFrame :: forall s e m a. (Framed e m, Exception s) => NixLevel -> s -> m a -> m a
withFrame level f = local (over hasLens (NixFrame level (toException f) :))
throwError :: forall s e m a. (Framed e m, Frame s, MonadThrow m) => s -> m a
throwError :: forall s e m a. (Framed e m, Exception s, MonadThrow m) => s -> m a
throwError err = do
context <- asks (view hasLens)
traceM "Throwing error..."
throwM $ NixException (NixFrame Error (toFrame err):context)
throwM $ NixException (NixFrame Error (toException err):context)

29
src/Nix/Lint.hs
View File

@ -29,7 +29,6 @@ import Control.Monad.Catch
import Control.Monad.Fix
import Control.Monad.Reader (MonadReader)
import Control.Monad.ST
import Control.Monad.ST.Unsafe
import Control.Monad.Trans.Reader
-- import qualified Data.ByteString as BS
import Data.Coerce
@ -39,7 +38,6 @@ import Data.List
import Data.STRef
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Void
import Nix.Atoms
import Nix.Context
import Nix.Convert
@ -66,7 +64,7 @@ data NTypeF (m :: * -> *) r
| TStr
| TList r
| TSet (Maybe (HashMap Text r))
| TClosure (Params Void) (m (Symbolic m) -> m (Symbolic m))
| TClosure (Params ()) (m (Symbolic m) -> m (Symbolic m))
| TPath
| TBuiltin String (SThunk m -> m (Symbolic m))
deriving Functor
@ -122,7 +120,7 @@ unpackSymbolic = readVar . coerce
type MonadLint e m = (Scoped e (SThunk m) m, Framed e m, MonadVar m)
symerr :: forall e m a. MonadLint e m => String -> m a
symerr = evalError @(Symbolic m)
symerr = evalError @(Symbolic m) . ErrorCall
renderSymbolic :: MonadLint e m => Symbolic m -> m String
renderSymbolic = unpackSymbolic >=> \case
@ -182,9 +180,9 @@ merge context = go
then go xs ys
else (TSet (Just m) :) <$> go xs ys
(TClosure {}, TClosure {}) ->
throwError "Cannot unify functions"
throwError $ ErrorCall "Cannot unify functions"
(TBuiltin _ _, TBuiltin _ _) ->
throwError "Cannot unify builtin functions"
throwError $ ErrorCall "Cannot unify builtin functions"
_ | compareTypes x y == LT -> go xs (y:ys)
| compareTypes x y == GT -> go (x:xs) ys
| otherwise -> error "impossible"
@ -227,7 +225,7 @@ unify context (Symbolic x) (Symbolic y) = do
then do
-- x' <- renderSymbolic (Symbolic x)
-- y' <- renderSymbolic (Symbolic y)
throwError "Cannot unify "
throwError $ ErrorCall "Cannot unify "
-- ++ show x' ++ " with " ++ show y'
-- ++ " in context: " ++ show context
else do
@ -296,7 +294,7 @@ instance MonadLint e m => MonadEval (Symbolic m) m where
pushWeakScope ?? body $ force s $ unpackSymbolic >=> \case
NMany [TSet (Just s')] -> return s'
NMany [TSet Nothing] -> error "NYI: with unknown"
_ -> throwError "scope must be a set in with statement"
_ -> throwError $ ErrorCall "scope must be a set in with statement"
evalIf cond t f = do
t' <- t
@ -312,7 +310,7 @@ instance MonadLint e m => MonadEval (Symbolic m) m where
pure body'
evalApp = (fmap snd .) . lintApp (NBinary NApp () ())
evalAbs params body = mkSymbolic [TClosure params body]
evalAbs params body = mkSymbolic [TClosure (void params) body]
evalError = throwError
@ -362,7 +360,8 @@ lintApp :: forall e m. MonadLint e m
=> NExprF () -> Symbolic m -> m (Symbolic m)
-> m (HashMap VarName (Symbolic m), Symbolic m)
lintApp context fun arg = unpackSymbolic fun >>= \case
NAny -> throwError "Cannot apply something not known to be a function"
NAny -> throwError $ ErrorCall
"Cannot apply something not known to be a function"
NMany xs -> do
(args:_, ys) <- fmap unzip $ forM xs $ \case
TClosure _params _f -> arg >>= unpackSymbolic >>= \case
@ -372,10 +371,10 @@ lintApp context fun arg = unpackSymbolic fun >>= \case
NMany [TSet (Just _)] -> do
error "NYI"
NMany _ -> throwError "NYI: lintApp NMany not set"
TBuiltin _ _f -> throwError "NYI: lintApp builtin"
TSet _m -> throwError "NYI: lintApp Set"
_x -> throwError "Attempt to call non-function"
NMany _ -> throwError $ ErrorCall "NYI: lintApp NMany not set"
TBuiltin _ _f -> throwError $ ErrorCall "NYI: lintApp builtin"
TSet _m -> throwError $ ErrorCall "NYI: lintApp Set"
_x -> throwError $ ErrorCall "Attempt to call non-function"
y <- everyPossible
(args,) <$> foldM (unify context) y ys
@ -400,7 +399,7 @@ instance MonadVar (Lint s) where
-- readFile x = Lint $ ReaderT $ \_ -> unsafeIOToST $ BS.readFile x
instance MonadThrow (Lint s) where
throwM e = Lint $ ReaderT $ \_ -> unsafeIOToST $ throw e
throwM e = Lint $ ReaderT $ \_ -> throw e
runLintM :: Options -> Lint s a -> ST s a
runLintM opts = flip runReaderT (newContext opts) . runLint

2
src/Nix/Normal.hs
View File

@ -27,7 +27,7 @@ import Nix.Value
newtype NormalLoop m = NormalLoop (NValue m)
deriving Show
instance Typeable m => Frame (NormalLoop m)
instance Typeable m => Exception (NormalLoop m)
normalFormBy
:: forall e m. (Framed e m, MonadVar m, Typeable m)

15
src/Nix/Render/Frame.hs
View File

@ -61,7 +61,7 @@ renderFrames (x:xs) = do
framePos :: forall v (m :: * -> *). (Typeable m, Typeable v) => NixFrame
-> Maybe SourcePos
framePos (NixFrame _ f)
| Just (e :: EvalFrame m v) <- fromFrame f = case e of
| Just (e :: EvalFrame m v) <- fromException f = case e of
EvaluatingExpr _ (Fix (Compose (Ann (SrcSpan beg _) _))) ->
Just beg
_ -> Nothing
@ -72,14 +72,13 @@ renderFrame :: forall v e m.
MonadFile m, Typeable m, Typeable v)
=> NixFrame -> m [Doc]
renderFrame (NixFrame level f)
| Just (e :: EvalFrame m v) <- fromFrame f = renderEvalFrame level e
| Just (e :: ThunkLoop) <- fromFrame f = renderThunkLoop level e
| Just (e :: ValueFrame m) <- fromFrame f = renderValueFrame level e
| Just (_ :: NormalLoop m) <- fromFrame f =
| Just (e :: EvalFrame m v) <- fromException f = renderEvalFrame level e
| Just (e :: ThunkLoop) <- fromException f = renderThunkLoop level e
| Just (e :: ValueFrame m) <- fromException f = renderValueFrame level e
| Just (_ :: NormalLoop m) <- fromException f =
pure [text "<<loop during normalization>>"]
| Just (e :: ExecFrame m) <- fromFrame f = renderExecFrame level e
| Just (e :: String) <- fromFrame f = pure [text e]
| Just (e :: Doc) <- fromFrame f = pure [e]
| Just (e :: ExecFrame m) <- fromException f = renderExecFrame level e
| Just (e :: ErrorCall) <- fromException f = pure [text (show e)]
| otherwise = error $ "Unrecognized frame: " ++ show f
wrapExpr :: NExprF r -> NExpr

14
src/Nix/Thunk.hs
View File

@ -15,7 +15,9 @@
module Nix.Thunk where
import Nix.Frames
import Control.Exception
import Control.Monad.Catch
import Data.Typeable
#if ENABLE_TRACING
import Data.IORef
@ -49,7 +51,7 @@ data Thunk m v
newtype ThunkLoop = ThunkLoop (Maybe Int)
deriving (Show, Typeable)
instance Frame ThunkLoop
instance Exception ThunkLoop
valueRef :: v -> Thunk m v
valueRef = Value
@ -64,7 +66,7 @@ buildThunk action =
#endif
<$> newVar False <*> newVar (Deferred action)
forceThunk :: (Framed e m, MonadVar m) => Thunk m v -> (v -> m a) -> m a
forceThunk :: (MonadVar m, MonadThrow m) => Thunk m v -> (v -> m a) -> m a
forceThunk (Value ref) k = k ref
#if ENABLE_TRACING
forceThunk (Thunk n active ref) k = do
@ -79,9 +81,9 @@ forceThunk (Thunk _ active ref) k = do
if nowActive
then
#if ENABLE_TRACING
throwError $ ThunkLoop (Just n)
throwM $ ThunkLoop (Just n)
#else
throwError $ ThunkLoop Nothing
throwM $ ThunkLoop Nothing
#endif
else do
#if ENABLE_TRACING
@ -92,7 +94,7 @@ forceThunk (Thunk _ active ref) k = do
_ <- atomicModifyVar active (False,)
k v
forceEffects :: (Framed e m, MonadVar m) => Thunk m v -> (v -> m a) -> m a
forceEffects :: MonadVar m => Thunk m v -> (v -> m a) -> m a
forceEffects (Value ref) k = k ref
forceEffects (Thunk _ active ref) k = do
nowActive <- atomicModifyVar active (True,)

17
src/Nix/Type/Env.hs
View File

@ -25,22 +25,23 @@ import Data.Semigroup
-- Typing Environment
-------------------------------------------------------------------------------
newtype Env = TypeEnv { types :: Map.Map Name Scheme }
newtype Env = TypeEnv { types :: Map.Map Name [Scheme] }
deriving (Eq, Show)
empty :: Env
empty = TypeEnv Map.empty
extend :: Env -> (Name, Scheme) -> Env
extend :: Env -> (Name, [Scheme]) -> Env
extend env (x, s) = env { types = Map.insert x s (types env) }
remove :: Env -> Name -> Env
remove (TypeEnv env) var = TypeEnv (Map.delete var env)
extends :: Env -> [(Name, Scheme)] -> Env
extends env xs = env { types = Map.union (Map.fromList xs) (types env) }
extends :: Env -> [(Name, [Scheme])] -> Env
extends env xs =
env { types = Map.union (Map.fromList xs) (types env) }
lookup :: Name -> Env -> Maybe Scheme
lookup :: Name -> Env -> Maybe [Scheme]
lookup key (TypeEnv tys) = Map.lookup key tys
merge :: Env -> Env -> Env
@ -50,15 +51,15 @@ mergeEnvs :: [Env] -> Env
mergeEnvs = foldl' merge empty
singleton :: Name -> Scheme -> Env
singleton x y = TypeEnv (Map.singleton x y)
singleton x y = TypeEnv (Map.singleton x [y])
keys :: Env -> [Name]
keys (TypeEnv env) = Map.keys env
fromList :: [(Name, Scheme)] -> Env
fromList :: [(Name, [Scheme])] -> Env
fromList xs = TypeEnv (Map.fromList xs)
toList :: Env -> [(Name, Scheme)]
toList :: Env -> [(Name, [Scheme])]
toList (TypeEnv env) = Map.toList env
instance Semigroup Env where

389
src/Nix/Type/Infer.hs
View File

@ -5,7 +5,10 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
@ -13,17 +16,37 @@
module Nix.Type.Infer (
Constraint(..),
TypeError(..),
InferError(..),
Subst(..),
inferTop
) where
import Control.Applicative
import Control.Arrow
import Control.Monad.Catch
import Control.Monad.Except
import Control.Monad.Logic
import Control.Monad.Reader
import Control.Monad.ST
import Control.Monad.State
import Data.Coerce
import Data.Fix
import Data.Foldable
import qualified Data.HashMap.Lazy as M
import Data.List (delete, find, nub, intersect, (\\))
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromJust)
import Data.STRef
import Data.Semigroup
import qualified Data.Set as Set
import Data.Text (Text)
import Nix.Atoms
import Nix.Convert
import Nix.Eval (MonadEval(..))
import qualified Nix.Eval as Eval
import Nix.Expr.Types
import Nix.Expr.Types.Annotated
import Nix.Frames (Frame)
import Nix.Scope
import Nix.Thunk
import qualified Nix.Type.Assumption as As
@ -32,38 +55,19 @@ import qualified Nix.Type.Env as Env
import Nix.Type.Type
import Nix.Utils
import Control.Applicative
import Control.Arrow
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Data.Fix
import Data.Foldable
import Data.List (delete, find, nub, intersect, (\\))
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromJust)
import Data.Semigroup
import qualified Data.HashMap.Lazy as M
import qualified Data.Set as Set
import Data.Text (Text)
-------------------------------------------------------------------------------
-- Classes
-------------------------------------------------------------------------------
-- | Inference monad
newtype Infer a = Infer
newtype Infer s a = Infer
{ getInfer ::
ReaderT (Set.Set TVar, Scopes Infer Judgment) -- Monomorphic set
(StateT InferState -- Inference state
(Except TypeError)) -- Inference errors
a -- Result
ReaderT (Set.Set TVar, Scopes (Infer s) (JThunk s))
(StateT InferState (ExceptT InferError (ST s))) a
}
deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix,
MonadReader (Set.Set TVar, Scopes Infer Judgment),
MonadState InferState, MonadError TypeError)
MonadReader (Set.Set TVar, Scopes (Infer s) (JThunk s)),
MonadState InferState, MonadError InferError)
-- | Inference state
newtype InferState = InferState { count :: Int }
@ -74,9 +78,6 @@ initInfer = InferState { count = 0 }
data Constraint
= EqConst Type Type
| EqConstOneOf Type [Type]
-- ^ The first type must unify with the second. For example, integer
-- could unify with integer, or a type variable.
| ExpInstConst Type Scheme
| ImpInstConst Type (Set.Set TVar) Type
deriving (Show, Eq, Ord)
@ -94,11 +95,11 @@ instance Substitutable TVar where
instance Substitutable Type where
apply _ (TCon a) = TCon a
apply s (TSet a) = TSet (M.map (apply s) a)
apply s (TSubSet a) = TSubSet (M.map (apply s) a)
apply s (TSet b a) = TSet b (M.map (apply s) a)
apply s (TList a) = TList (map (apply s) a)
apply (Subst s) t@(TVar a) = Map.findWithDefault t a s
apply s (t1 `TArr` t2) = apply s t1 `TArr` apply s t2
apply s (TMany ts) = TMany (map (apply s) ts)
instance Substitutable Scheme where
apply (Subst s) (Forall as t) = Forall as $ apply s' t
@ -106,7 +107,6 @@ instance Substitutable Scheme where
instance Substitutable Constraint where
apply s (EqConst t1 t2) = EqConst (apply s t1) (apply s t2)
apply s (EqConstOneOf t1 t2) = EqConstOneOf (apply s t1) (apply s t2)
apply s (ExpInstConst t sc) = ExpInstConst (apply s t) (apply s sc)
apply s (ImpInstConst t1 ms t2) = ImpInstConst (apply s t1) (apply s ms) (apply s t2)
@ -123,10 +123,10 @@ class FreeTypeVars a where
instance FreeTypeVars Type where
ftv TCon{} = Set.empty
ftv (TVar a) = Set.singleton a
ftv (TSet a) = Set.unions (map ftv (M.elems a))
ftv (TSubSet a) = Set.unions (map ftv (M.elems a))
ftv (TSet _ a) = Set.unions (map ftv (M.elems a))
ftv (TList a) = Set.unions (map ftv a)
ftv (t1 `TArr` t2) = ftv t1 `Set.union` ftv t2
ftv (TMany ts) = Set.unions (map ftv ts)
instance FreeTypeVars TVar where
ftv = Set.singleton
@ -146,30 +146,36 @@ class ActiveTypeVars a where
instance ActiveTypeVars Constraint where
atv (EqConst t1 t2) = ftv t1 `Set.union` ftv t2
atv (EqConstOneOf 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
data TypeError
= UnificationFail Type Type
| InfiniteType TVar Type
| UnboundVariable Text
| UnboundVariables [Text]
| Ambigious [Constraint]
| UnificationMismatch [Type] [Type]
| forall s. Frame s => EvaluationError s
| InferenceAborted
deriving (Eq, Show)
deriving instance Show TypeError
data InferError
= TypeInferenceErrors [TypeError]
| TypeInferenceAborted
| forall s. Exception s => EvaluationError s
instance Semigroup TypeError where
typeError :: MonadError InferError m => TypeError -> m ()
typeError err = throwError $ TypeInferenceErrors [err]
deriving instance Show InferError
instance Exception InferError
instance Semigroup InferError where
x <> _ = x
instance Monoid TypeError where
mempty = InferenceAborted
instance Monoid InferError where
mempty = TypeInferenceAborted
mappend = (<>)
-------------------------------------------------------------------------------
@ -177,42 +183,57 @@ instance Monoid TypeError where
-------------------------------------------------------------------------------
-- | Run the inference monad
runInfer :: Infer a -> Either TypeError a
runInfer m =
runExcept $ evalStateT (runReaderT (getInfer m) (Set.empty, emptyScopes)) initInfer
runInfer' :: Infer s a -> ST s (Either InferError a)
runInfer' = runExceptT
. (`evalStateT` initInfer)
. (`runReaderT` (Set.empty, emptyScopes))
. getInfer
inferType :: Env -> NExpr -> Infer (Subst, Type)
runInfer :: (forall s. Infer s a) -> Either InferError a
runInfer m = runST (runInfer' m)
inferType :: Env -> NExpr -> Infer s [(Subst, Type)]
inferType env ex = do
Judgment as cs t <- infer ex
let unbounds = Set.fromList (As.keys as) `Set.difference` Set.fromList (Env.keys env)
unless (Set.null unbounds) $ throwError $ UnboundVariable (Set.findMin unbounds)
let cs' = [ExpInstConst t s | (x, s) <- Env.toList env, t <- As.lookup x as]
subst <- solve (cs ++ cs')
return (subst, apply subst t)
let unbounds = Set.fromList (As.keys as) `Set.difference`
Set.fromList (Env.keys env)
unless (Set.null unbounds) $
typeError $ UnboundVariables (nub (Set.toList unbounds))
let cs' = [ ExpInstConst t s
| (x, ss) <- Env.toList env
, s <- ss
, t <- As.lookup x as]
inferState <- get
let eres = (`evalState` inferState) $ runSolver $ do
subst <- solve (cs ++ cs')
return (subst, subst `apply` t)
case eres of
Left errs -> throwError $ TypeInferenceErrors errs
Right xs -> pure xs
-- | Solve for the toplevel type of an expression in a given environment
inferExpr :: Env -> NExpr -> Either TypeError Scheme
inferExpr :: Env -> NExpr -> Either InferError [Scheme]
inferExpr env ex = case runInfer (inferType env ex) of
Left err -> Left err
Right (subst, ty) -> Right $ closeOver $ apply subst ty
Right xs -> Right $ map (\(subst, ty) -> closeOver (subst `apply` ty)) xs
-- | Canonicalize and return the polymorphic toplevel type.
closeOver :: Type -> Scheme
closeOver = normalize . generalize Set.empty
extendMSet :: TVar -> Infer a -> Infer a
extendMSet :: TVar -> Infer s a -> Infer s a
extendMSet x = Infer . local (first (Set.insert x)) . getInfer
letters :: [String]
letters = [1..] >>= flip replicateM ['a'..'z']
fresh :: Infer Type
fresh = Infer $ do
fresh :: MonadState InferState m => m Type
fresh = do
s <- get
put s{count = count s + 1}
return $ TVar $ TV (letters !! count s)
instantiate :: Scheme -> Infer Type
instantiate :: MonadState InferState m => Scheme -> m Type
instantiate (Forall as t) = do
as' <- mapM (const fresh) as
let s = Subst $ Map.fromList $ zip as as'
@ -224,9 +245,9 @@ generalize free t = Forall as t
unops :: Type -> NUnaryOp -> [Constraint]
unops u1 = \case
NNot -> [ EqConst u1 ( typeFun [typeBool, typeBool] ) ]
NNeg -> [ EqConstOneOf u1 [ typeFun [typeInt, typeInt]
, typeFun [typeFloat, typeFloat] ] ]
NNot -> [ EqConst u1 (typeFun [typeBool, typeBool]) ]
NNeg -> [ EqConst u1 (TMany [ typeFun [typeInt, typeInt]
, typeFun [typeFloat, typeFloat] ]) ]
binops :: Type -> NBinaryOp -> [Constraint]
binops u1 = \case
@ -242,52 +263,68 @@ binops u1 = \case
NLt -> inequality
NLte -> inequality
NAnd -> [ EqConst u1 ( typeFun [typeBool, typeBool, typeBool]) ]
NOr -> [ EqConst u1 ( typeFun [typeBool, typeBool, typeBool]) ]
NImpl -> [ EqConst u1 ( typeFun [typeBool, typeBool, typeBool]) ]
NAnd -> [ EqConst u1 (typeFun [typeBool, typeBool, typeBool]) ]
NOr -> [ EqConst u1 (typeFun [typeBool, typeBool, typeBool]) ]
NImpl -> [ EqConst u1 (typeFun [typeBool, typeBool, typeBool]) ]
NConcat -> [ EqConstOneOf u1 [ typeFun [typeList, typeList, typeList]
, typeFun [typeList, typeNull, typeList]
, typeFun [typeNull, typeList, typeList]
] ]
NConcat -> [ EqConst u1 (TMany [ typeFun [typeList, typeList, typeList]
, typeFun [typeList, typeNull, typeList]
, typeFun [typeNull, typeList, typeList]
]) ]
NUpdate -> [ EqConstOneOf u1 [ typeFun [typeSet, typeSet, typeSet]
, typeFun [typeSet, typeNull, typeSet]
, typeFun [typeNull, typeSet, typeSet]
] ]
NUpdate -> [ EqConst u1 (TMany [ typeFun [typeSet, typeSet, typeSet]
, typeFun [typeSet, typeNull, typeSet]
, typeFun [typeNull, typeSet, typeSet]
]) ]
NPlus -> [ EqConstOneOf u1 [ typeFun [typeInt, typeInt, typeInt]
, typeFun [typeFloat, typeFloat, typeFloat]
, typeFun [typeInt, typeFloat, typeFloat]
, typeFun [typeFloat, typeInt, typeFloat]
, typeFun [typeString, typeString, typeString]
, typeFun [typePath, typePath, typePath]
, typeFun [typeString, typeString, typePath]
] ]
NPlus -> [ EqConst u1 (TMany [ typeFun [typeInt, typeInt, typeInt]
, typeFun [typeFloat, typeFloat, typeFloat]
, typeFun [typeInt, typeFloat, typeFloat]
, typeFun [typeFloat, typeInt, typeFloat]
, typeFun [typeString, typeString, typeString]
, typeFun [typePath, typePath, typePath]
, typeFun [typeString, typeString, typePath]
]) ]
NMinus -> arithmetic
NMult -> arithmetic
NDiv -> arithmetic
where
inequality =
[ EqConstOneOf u1 [ typeFun [typeInt, typeInt, typeBool]
, typeFun [typeFloat, typeFloat, typeBool]
, typeFun [typeInt, typeFloat, typeBool]
, typeFun [typeFloat, typeInt, typeBool]
] ]
[ EqConst u1 (TMany [ typeFun [typeInt, typeInt, typeBool]
, typeFun [typeFloat, typeFloat, typeBool]
, typeFun [typeInt, typeFloat, typeBool]
, typeFun [typeFloat, typeInt, typeBool]
]) ]
arithmetic =
[ EqConstOneOf u1 [ typeFun [typeInt, typeInt, typeInt]
, typeFun [typeFloat, typeFloat, typeFloat]
, typeFun [typeInt, typeFloat, typeFloat]
, typeFun [typeFloat, typeInt, typeFloat]
] ]
[ EqConst u1 (TMany [ typeFun [typeInt, typeInt, typeInt]
, typeFun [typeFloat, typeFloat, typeFloat]
, typeFun [typeInt, typeFloat, typeFloat]
, typeFun [typeFloat, typeInt, typeFloat]
]) ]
instance MonadThunk Judgment Judgment Infer where
thunk = id
force v f = f v
value = id
instance MonadVar (Infer s) where
type Var (Infer s) = STRef s
instance MonadEval Judgment Infer where
newVar x = Infer $ lift $ lift $ lift $ newSTRef x
readVar x = Infer $ lift $ lift $ lift $ readSTRef x
writeVar x y = Infer $ lift $ lift $ lift $ writeSTRef x y
atomicModifyVar x f = Infer $ lift $ lift $ lift $ do
res <- snd . f <$> readSTRef x
_ <- modifySTRef x (fst . f)
return res
newtype JThunk s = JThunk (Thunk (Infer s) (Judgment s))
instance MonadThrow (Infer s) where
throwM = throwError . EvaluationError
instance MonadThunk (Judgment s) (JThunk s) (Infer s) where
thunk = fmap JThunk . buildThunk
force = forceThunk . coerce
value = JThunk . valueRef
instance MonadEval (Judgment s) (Infer s) where
freeVariable var = do
tv <- fresh
return $ Judgment (As.singleton var tv) [] tv
@ -295,7 +332,7 @@ instance MonadEval Judgment Infer where
evaledSym _ = pure
evalCurPos =
return $ Judgment As.empty [] $ TSet $ M.fromList
return $ Judgment As.empty [] $ TSet False $ M.fromList
[ ("file", typePath)
, ("line", typeInt)
, ("col", typeInt) ]
@ -359,49 +396,72 @@ instance MonadEval Judgment Infer where
(cs ++ [EqConst t' tv | t' <- As.lookup x as])
(tv `TArr` t)
evalAbs (ParamSet _x _variadic _mname) _e = undefined
evalAbs (ParamSet ps _variadic _mname) e = do
js <- fmap concat $ forM ps $ \(name, mdef) -> case mdef of
Just _ -> pure []
Nothing -> 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)
names = map fst js
Judgment as cs t <-
(\f -> foldr f (e (pure (Judgment env [] (TSet True tys)))) js)
$ \(_, TVar a) rest -> extendMSet a rest
return $ Judgment
(foldl' As.remove as names)
(cs ++ [ EqConst t' (tys M.! x)
| x <- names
, t' <- As.lookup x as])
-- jww (2018-05-01): How do we recover the actual args used?
(t `TArr` t)
evalError = throwError . EvaluationError
data Judgment = Judgment
data Judgment s = Judgment
{ assumptions :: As.Assumption
, typeConstraints :: [Constraint]
, inferredType :: Type
}
deriving Show
instance FromValue (Text, DList Text) Infer Judgment where
instance FromValue (Text, DList Text) (Infer s) (Judgment s) where
fromValueMay _ = return Nothing
fromValue _ = error "Unused"
instance FromValue (AttrSet Judgment, AttrSet SourcePos) Infer Judgment where
-- jww (2018-04-30): How can we do this? TSet doesn't record enough information
fromValueMay (Judgment _ _ (TSet xs)) =
pure $ Just (M.mapWithKey (\k v -> Judgment (As.singleton k v) [] v) xs, M.empty)
instance FromValue (AttrSet (JThunk s), AttrSet SourcePos) (Infer s) (Judgment s) where
fromValueMay (Judgment _ _ (TSet _ xs)) = do
let sing _ = Judgment As.empty []
pure $ Just (M.mapWithKey (\k v -> value (sing k v)) xs, M.empty)
fromValueMay _ = pure Nothing
fromValue = fromValueMay >=> \case
Just v -> pure v
Nothing -> pure (M.empty, M.empty)
instance ToValue (AttrSet Judgment, AttrSet SourcePos) Infer Judgment where
toValue (xs, _) = pure $ Judgment
(foldr (As.merge . assumptions) As.empty xs)
(concatMap typeConstraints xs)
(TSet (M.map inferredType xs))
instance ToValue (AttrSet (JThunk s), AttrSet SourcePos) (Infer s) (Judgment s) where
toValue (xs, _) = Judgment
<$> foldrM go As.empty xs
<*> (concat <$> traverse (`force` (pure . typeConstraints)) xs)
<*> (TSet True <$> traverse (`force` (pure . inferredType)) xs)
where
go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest
instance ToValue [Judgment] Infer Judgment where
toValue xs = pure $ Judgment
(foldr (As.merge . assumptions) As.empty xs)
(concatMap typeConstraints xs)
(TList (map inferredType xs))
instance ToValue [JThunk s] (Infer s) (Judgment s) where
toValue xs = Judgment
<$> foldrM go As.empty xs
<*> (concat <$> traverse (`force` (pure . typeConstraints)) xs)
<*> (TList <$> traverse (`force` (pure . inferredType)) xs)
where
go x rest = force x $ \x' -> pure $ As.merge (assumptions x') rest
instance ToValue Bool Infer Judgment where
instance ToValue Bool (Infer s) (Judgment s) where
toValue _ = pure $ Judgment As.empty [] typeBool
infer :: NExpr -> Infer Judgment
infer :: NExpr -> Infer s (Judgment s)
infer = cata Eval.eval
inferTop :: Env -> [(Text, NExpr)] -> Either TypeError Env
inferTop :: Env -> [(Text, NExpr)] -> Either InferError Env
inferTop env [] = Right env
inferTop env ((name, ex):xs) = case inferExpr env ex of
Left err -> Left err
@ -415,15 +475,15 @@ normalize (Forall _ body) = Forall (map snd ord) (normtype body)
fv (TVar a) = [a]
fv (TArr a b) = fv a ++ fv b
fv (TCon _) = []
fv (TSet a) = concatMap fv (M.elems a)
fv (TSubSet a) = concatMap fv (M.elems a)
fv (TSet _ a) = concatMap fv (M.elems a)
fv (TList a) = concatMap fv a
fv (TMany ts) = concatMap fv ts
normtype (TArr a b) = TArr (normtype a) (normtype b)
normtype (TCon a) = TCon a
normtype (TSet a) = TSet (M.map normtype a)
normtype (TSubSet a) = TSubSet (M.map normtype a)
normtype (TSet b a) = TSet b (M.map normtype a)
normtype (TList a) = TList (map normtype a)
normtype (TMany ts) = TMany (map normtype ts)
normtype (TVar a) =
case Prelude.lookup a ord of
Just x -> TVar x
@ -433,15 +493,34 @@ normalize (Forall _ body) = Forall (map snd ord) (normtype body)
-- Constraint Solver
-------------------------------------------------------------------------------
newtype Solver m a = Solver (LogicT (StateT [TypeError] m) a)
deriving (Functor, Applicative, Alternative, Monad, MonadPlus,
MonadLogic, MonadState [TypeError])
instance MonadTrans Solver where
lift = Solver . lift . lift
instance Monad m => MonadError TypeError (Solver m) where
throwError err = Solver $ lift (modify (err:)) >> mzero
catchError _ _ = error "This is never used"
runSolver :: Monad m => Solver m a -> m (Either [TypeError] [a])
runSolver (Solver s) = do
res <- runStateT (observeAllT s) []
pure $ case res of
(x:xs, _) -> Right (x:xs)
(_, es) -> Left (nub es)
-- | The empty substitution
emptySubst :: Subst
emptySubst = mempty
-- | Compose substitutions
compose :: Subst -> Subst -> Subst
(Subst s1) `compose` (Subst s2) = Subst $ Map.map (apply (Subst s1)) s2 `Map.union` s1
Subst s1 `compose` Subst s2 =
Subst $ Map.map (apply (Subst s1)) s2 `Map.union` s1
unifyMany :: [Type] -> [Type] -> Infer Subst
unifyMany :: Monad m => [Type] -> [Type] -> Solver m Subst
unifyMany [] [] = return emptySubst
unifyMany (t1 : ts1) (t2 : ts2) =
do su1 <- unifies t1 t2
@ -449,21 +528,36 @@ unifyMany (t1 : ts1) (t2 : ts2) =
return (su2 `compose` su1)
unifyMany t1 t2 = throwError $ UnificationMismatch t1 t2
unifies :: Type -> Type -> Infer Subst
allSameType :: [Type] -> Bool
allSameType [] = True
allSameType [_] = True
allSameType (x:y:ys) = x == y && allSameType (y:ys)
unifies :: Monad m => Type -> Type -> Solver m Subst
unifies t1 t2 | t1 == t2 = return emptySubst
unifies (TVar v) t = v `bind` t
unifies t (TVar v) = v `bind` t
unifies (TList _) (TList _) = return emptySubst
unifies (TSet b) (TSubSet s)
unifies (TList xs) (TList ys)
| allSameType xs && allSameType ys = case (xs, ys) of
(x:_, y:_) -> unifies x y
_ -> return emptySubst
| length xs == length ys = unifyMany xs ys
-- We assume that lists of different lengths containing various types cannot
-- be unified.
unifies t1@(TList _) t2@(TList _) = throwError $ UnificationFail t1 t2
unifies (TSet True _) (TSet True _) = return emptySubst
unifies (TSet False b) (TSet True s)
| M.keys b `intersect` M.keys s == M.keys s = return emptySubst
unifies (TSubSet s) (TSet b)
| M.keys b `intersect` M.keys s == M.keys s = return emptySubst
unifies (TSet s) (TSet b)
unifies (TSet True s) (TSet False b)
| M.keys b `intersect` M.keys s == M.keys b = return emptySubst
unifies (TSet False s) (TSet False b)
| null (M.keys b \\ M.keys s) = return emptySubst
unifies (TArr t1 t2) (TArr t3 t4) = unifyMany [t1, t2] [t3, t4]
unifies (TMany t1s) t2 = considering t1s >>- unifies ?? t2
unifies t1 (TMany t2s) = considering t2s >>- unifies t1
unifies t1 t2 = throwError $ UnificationFail t1 t2
bind :: TVar -> Type -> Infer Subst
bind :: Monad m => TVar -> Type -> Solver m Subst
bind a t | t == TVar a = return emptySubst
| occursCheck a t = throwError $ InfiniteType a t
| otherwise = return (Subst $ Map.singleton a t)
@ -475,36 +569,27 @@ nextSolvable :: [Constraint] -> (Constraint, [Constraint])
nextSolvable xs = fromJust (find solvable (chooseOne xs))
where
chooseOne xs = [(x, ys) | x <- xs, let ys = delete x xs]
solvable (EqConst{}, _) = True
solvable (EqConstOneOf{}, _) = True
solvable (ExpInstConst{}, _) = True
solvable (ImpInstConst _t1 ms t2, cs) =
Set.null ((ftv t2 `Set.difference` ms) `Set.intersection` atv cs)
solve :: [Constraint] -> Infer Subst
considering :: [a] -> Solver m a
considering xs = Solver $ LogicT $ \c n -> foldr c n xs
solve :: MonadState InferState m => [Constraint] -> Solver m Subst
solve [] = return emptySubst
solve cs = solve' (nextSolvable cs)
where
solve' (EqConst t1 t2, cs) =
unifies t1 t2 >>- \su1 ->
solve (apply su1 cs) >>- \su2 ->
return (su2 `compose` su1)
solve' :: (Constraint, [Constraint]) -> Infer Subst
solve' (EqConst t1 t2, cs) = do
su1 <- unifies t1 t2
su2 <- solve (apply su1 cs)
return (su2 `compose` su1)
solve' (ImpInstConst t1 ms t2, cs) =
solve (ExpInstConst t1 (generalize ms t2) : cs)
solve' (EqConstOneOf t1 t2, cs) = do
-- jww (2018-04-30): Instead of picking the first that matches, collect all
-- that match into a 'TVariant [Type]' type, so that we can report that a
-- function like 'x: y: x + y' has type: forall a b. a one of integer,
-- float, string, b the same as a, or compatible, result is determined by
-- the finally decided type of the function (in this case, one of int,
-- float, string or path, based on the types of a and b).
su1 <- asum (map (unifies t1) t2)
su2 <- solve (apply su1 cs)
return (su2 `compose` su1)
solve' (ImpInstConst t1 ms t2, cs) =
solve (ExpInstConst t1 (generalize ms t2) : cs)
solve' (ExpInstConst t s, cs) = do
s' <- instantiate s
solve (EqConst t s' : cs)
solve' (ExpInstConst t s, cs) = do
s' <- lift $ instantiate s
solve (EqConst t s' : cs)

14
src/Nix/Type/Type.hs
View File

@ -8,12 +8,12 @@ newtype TVar = TV String
deriving (Show, Eq, Ord)
data Type
= TVar TVar -- type variable
| TCon String -- known type
| TSet (AttrSet Type) -- heterogenous map: { a = b; }
| TSubSet (AttrSet Type) -- subset of heterogenous map: { a = b; ... }
| TList [Type] -- heterogenous list
| TArr Type Type -- type -> type
= TVar TVar -- type variable
| TCon String -- known type
| TSet Bool (AttrSet Type) -- heterogenous map, bool if variadic
| TList [Type] -- heterogenous list
| TArr Type Type -- type -> type
| TMany [Type] -- variant type
deriving (Show, Eq, Ord)
data Scheme = Forall [TVar] Type -- forall a b. a -> b
@ -21,7 +21,7 @@ data Scheme = Forall [TVar] Type -- forall a b. a -> b
-- This models a set that unifies with any other set.
typeSet :: Type
typeSet = TSubSet M.empty
typeSet = TSet True M.empty
typeList :: Type
typeList = TList []

8
src/Nix/Value.hs
View File

@ -35,7 +35,6 @@ import Data.Monoid (appEndo)
import Data.Text (Text)
import Data.These
import Data.Typeable (Typeable)
import Data.Void
import GHC.Generics
import Nix.Atoms
import Nix.Expr.Types
@ -56,7 +55,7 @@ data NValueF m r
| NVPathF FilePath
| NVListF [r]
| NVSetF (AttrSet r) (AttrSet SourcePos)
| NVClosureF (Params Void) (m (NValue m) -> m (NValue m))
| NVClosureF (Params ()) (m (NValue m) -> m (NValue m))
-- ^ A function is a closed set of parameters representing the "call
-- signature", used at application time to check the type of arguments
-- passed to the function. Since it supports default values which may
@ -182,8 +181,7 @@ instance Ord (NValue m) where
NVPath x <= NVPath y = x < y
_ <= _ = False
checkComparable :: (Framed e m, MonadThrow m, Typeable m)
=> NValue m -> NValue m -> m ()
checkComparable :: (Framed e m, Typeable m) => NValue m -> NValue m -> m ()
checkComparable x y = case (x, y) of
(NVConstant (NFloat _), NVConstant (NInt _)) -> pure ()
(NVConstant (NInt _), NVConstant (NFloat _)) -> pure ()
@ -327,4 +325,4 @@ data ValueFrame m
| Expectation ValueType (NValue m)
deriving (Show, Typeable)
instance Typeable m => Frame (ValueFrame m)
instance Typeable m => Exception (ValueFrame m)