128 lines
4.8 KiB
Haskell
128 lines
4.8 KiB
Haskell
{-# LANGUAGE DeriveDataTypeable #-}
|
|
{-# LANGUAGE DeriveFunctor #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE ConstraintKinds #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
module Nix.Monad where
|
|
|
|
import Data.Coerce
|
|
import Data.Fix
|
|
import Data.HashMap.Lazy (HashMap)
|
|
import Data.Monoid (appEndo)
|
|
import Data.Text (Text)
|
|
import Data.Typeable (Typeable)
|
|
import GHC.Generics
|
|
import Nix.Atoms
|
|
import Nix.Expr.Types
|
|
import Nix.Scope
|
|
import Nix.Thunk
|
|
import Nix.Utils
|
|
import System.Posix.Files
|
|
|
|
newtype NThunk m = NThunk (Thunk m (NValue m))
|
|
|
|
thunk :: (Functor m, MonadInterleave m) => m (NValue m) -> m (NThunk m)
|
|
thunk = fmap coerce . buildThunk
|
|
|
|
force :: Applicative m => NThunk m -> m (NValue m)
|
|
force = forceThunk . coerce
|
|
|
|
valueThunk :: forall m. Applicative m => NValue m -> NThunk m
|
|
valueThunk = coerce . valueRef @m
|
|
|
|
-- | An 'NValue' is the most reduced form of an 'NExpr' after evaluation
|
|
-- is completed.
|
|
data NValueF m r
|
|
= NVConstant NAtom
|
|
-- | A string has a value and a context, which can be used to record what a
|
|
-- string has been build from
|
|
| NVStr Text (DList Text)
|
|
| NVList [r]
|
|
| NVSet (HashMap Text r)
|
|
| NVClosure (Scopes m r) (Params (m r)) (m r)
|
|
-- ^ 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
|
|
-- depend on other values within the final argument set, this
|
|
-- dependency is represented as a set of pending evaluations. The
|
|
-- arguments are finally normalized into a set which is passed to the
|
|
-- function.
|
|
--
|
|
-- Note that 'm r' is being used here because effectively a function
|
|
-- and its set of default arguments is "never fully evaluated". This
|
|
-- enforces in the type that it must be re-evaluated for each call.
|
|
| NVLiteralPath FilePath
|
|
| NVEnvPath FilePath
|
|
| NVBuiltin String (NThunk m -> m (NValue m))
|
|
-- ^ A builtin function is itself already in normal form. Also, it may
|
|
-- or may not choose to evaluate its argument in the production of a
|
|
-- result.
|
|
deriving (Generic, Typeable, Functor)
|
|
|
|
-- | An 'NValueNF' is a fully evaluated value in normal form. An 'NValue m' is
|
|
-- a value in head normal form, where only the "top layer" has been
|
|
-- evaluated. An action of type 'm (NValue m)' is a pending evualation that
|
|
-- has yet to be performed. An 'NThunk m' is either a pending evaluation, or
|
|
-- a value in head normal form. A 'ValueSet' is a set of mappings from keys
|
|
-- to thunks.
|
|
|
|
type NValueNF m = Fix (NValueF m) -- normal form
|
|
type NValue m = NValueF m (NThunk m) -- head normal form
|
|
type ValueSet m = HashMap Text (NThunk m)
|
|
|
|
instance Show f => Show (NValueF m f) where
|
|
showsPrec = flip go where
|
|
go (NVConstant atom) = showsCon1 "NVConstant" atom
|
|
go (NVStr text context) = showsCon2 "NVStr" text (appEndo context [])
|
|
go (NVList list) = showsCon1 "NVList" list
|
|
go (NVSet attrs) = showsCon1 "NVSet" attrs
|
|
go (NVClosure s r _) = showsCon2 "NVClosure" s (() <$ r)
|
|
go (NVLiteralPath p) = showsCon1 "NVLiteralPath" p
|
|
go (NVEnvPath p) = showsCon1 "NVEnvPath" p
|
|
go (NVBuiltin name _) = showsCon1 "NVBuiltin" name
|
|
|
|
showsCon1 :: Show a => String -> a -> Int -> String -> String
|
|
showsCon1 con a d =
|
|
showParen (d > 10) $ showString (con ++ " ") . showsPrec 11 a
|
|
|
|
showsCon2 :: (Show a, Show b)
|
|
=> String -> a -> b -> Int -> String -> String
|
|
showsCon2 con a b d =
|
|
showParen (d > 10)
|
|
$ showString (con ++ " ")
|
|
. showsPrec 11 a
|
|
. showString " "
|
|
. showsPrec 11 b
|
|
|
|
builtin :: MonadNix m => String -> (NThunk m -> m (NValue m)) -> m (NValue m)
|
|
builtin name f = return $ NVBuiltin name f
|
|
|
|
builtin2 :: MonadNix m
|
|
=> String -> (NThunk m -> NThunk m -> m (NValue m)) -> m (NValue m)
|
|
builtin2 name f = builtin name (builtin name . f)
|
|
|
|
builtin3 :: MonadNix m
|
|
=> String -> (NThunk m -> NThunk m -> NThunk m -> m (NValue m))
|
|
-> m (NValue m)
|
|
builtin3 name f =
|
|
builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c
|
|
|
|
-- | A path into the nix store
|
|
newtype StorePath = StorePath { unStorePath :: FilePath }
|
|
|
|
class Monad m => MonadNix m where
|
|
-- | Import a path into the nix store, and return the resulting path
|
|
addPath :: FilePath -> m StorePath
|
|
|
|
-- | Determine the absolute path of relative path in the current context
|
|
makeAbsolutePath :: FilePath -> m FilePath
|
|
|
|
importFile :: NThunk m -> m (NValue m)
|
|
getEnvVar :: NThunk m -> m (NValue m)
|
|
|
|
listDirectory :: FilePath -> m [FilePath]
|
|
getSymbolicLinkStatus :: FilePath -> m FileStatus
|