Add NValue constructors for builtins

Nix/Builtins.hs

@@ -0,0 +1,97 @@
+
+module Nix.Builtins (baseEnv, builtins, evalTopLevelExpr) where
+
+import           Control.Applicative
+import           Control.Monad hiding (mapM, sequence)
+import           Control.Monad.Fix
+import           Data.Fix
+import qualified Data.Map as Map
+import           Data.Text (Text)
+import qualified Data.Text as Text
+import           Data.Traversable (mapM)
+import           Nix.Atoms
+import           Nix.Eval
+import           Nix.Expr (NExpr)
+import           Prelude hiding (mapM, sequence)
+
+-- | Evaluate a nix expression in the default context
+evalTopLevelExpr :: MonadFix m => NExpr -> m (NValue m)
+evalTopLevelExpr val = evalExpr val baseEnv
+
+baseEnv :: MonadFix m => ValueSet m
+baseEnv = Map.fromList $ [ ("builtins", Fix $ NVSet builtins) ] ++ topLevelBuiltins
+  where
+    topLevelBuiltins = map mapping $ filter isTopLevel builtinsList
+    -- builtins = Map.fromList $ map mapping $ builtinsList
+
+builtins :: MonadFix m => ValueSet m
+builtins = Map.fromList $ map mapping $ builtinsList
+
+data BuiltinType = Normal | TopLevel
+data Builtin m = Builtin {kind :: BuiltinType, mapping :: (Text, NValue m) }
+
+isTopLevel :: Builtin m -> Bool
+isTopLevel b = case kind b of
+                    Normal -> False
+                    TopLevel -> True
+
+builtinsList :: MonadFix m => [ Builtin m ]
+builtinsList = [
+      topLevel ("toString", prim_toString)
+    , basic    ("hasAttr" , prim_hasAttr)
+    , basic    ("getAttr" , prim_getAttr)
+    , basic    ("any"     , prim_any )
+    , basic    ("all"     , prim_all )
+  ]
+  where
+    basic = Builtin Normal
+    topLevel = Builtin TopLevel
+
+
+-- Helpers
+
+mkBool :: Bool -> NValue m
+mkBool = Fix . NVConstant . NBool
+
+extractBool :: NValue m -> Bool
+extractBool (Fix (NVConstant (NBool b))) = b
+extractBool _                            = error "Not a bool constant"
+
+evalPred :: NValue m -> NValue m -> m (NValue m)
+evalPred (Fix (NVFunction argset pred)) = pred . buildArgument argset
+evalPred pred = error $ "Trying to call a " ++ show pred
+
+
+-- Primops
+
+prim_toString :: MonadFix m => Functor m => NValue m
+prim_toString = Fix $ NVBuiltin1 "toString" $ toString
+toString :: MonadFix m => NValue m -> m (NValue m)
+toString s = return $ Fix $ NVStr $ valueText s
+
+prim_hasAttr :: MonadFix m => NValue m
+prim_hasAttr = Fix $ NVBuiltin2 "hasAttr" [] hasAttr
+hasAttr :: MonadFix m => NValue m -> NValue m -> m (NValue m)
+hasAttr (Fix (NVStr key)) (Fix (NVSet aset)) = return $ Fix $ NVConstant $ NBool $ Map.member key aset
+hasAttr key aset = error $ "Invalid types for builtin.hasAttr: " ++ show (key, aset)
+
+prim_getAttr :: MonadFix m => NValue m
+prim_getAttr = Fix $ NVBuiltin2 "getAttr" [] getAttr
+getAttr :: MonadFix m => NValue m -> NValue m -> m (NValue m)
+getAttr (Fix (NVStr key)) (Fix (NVSet aset)) = return $ Map.findWithDefault _err key aset
+  where _err = error ("Field does not exist " ++ Text.unpack key)
+getAttr key aset = error $ "Invalid types for builtin.getAttr: " ++ show (key, aset)
+
+
+prim_any :: MonadFix m => NValue m
+prim_any = Fix $ NVBuiltin2 "any" [] _any
+_any :: MonadFix m => NValue m -> NValue m -> m (NValue m)
+_any pred (Fix (NVList l)) = mkBool . any extractBool <$> mapM (evalPred pred) l
+_any _ list = error $ "builtins.any takes a list as second argument, not a " ++ show list
+
+prim_all :: MonadFix m => NValue m
+prim_all = Fix $ NVBuiltin2 "all" [] _all
+_all :: MonadFix m => NValue m -> NValue m -> m (NValue m)
+_all pred (Fix (NVList l)) = mkBool . all extractBool <$> mapM (evalPred pred) l
+_all _ list = error $ "builtins.all takes a list as second argument, not a " ++ show list
+

Nix/Eval.hs

@@ -30,6 +30,8 @@ data NValueF m r
     | NVFunction (Params r) (ValueSet m -> m r)
     | NVLiteralPath FilePath
     | NVEnvPath FilePath
+    | NVBuiltin1 String (NValue m -> m r)
+    | NVBuiltin2 String [r] (NValue m -> NValue m -> m r)
     deriving (Generic, Typeable, Functor)
 
 instance Show f => Show (NValueF m f) where
@@ -41,6 +43,8 @@ instance Show f => Show (NValueF m f) where
       go (NVFunction r _)  = showsCon1 "NVFunction" r
       go (NVLiteralPath p) = showsCon1 "NVLiteralPath" p
       go (NVEnvPath p)     = showsCon1 "NVEnvPath" p
+      go (NVBuiltin1 name _) = showsCon1 "NVBuiltin1" name
+      go (NVBuiltin2 name _ _) = showsCon1 "NVBuiltin2" name
 
       showsCon1 :: Show a => String -> a -> Int -> String -> String
       showsCon1 con a d = showParen (d > 10) $ showString (con ++ " ") . showsPrec 11 a
@@ -58,6 +62,8 @@ valueText = cata phi where
     phi (NVFunction _ _)  = error "Cannot coerce a function to a string"
     phi (NVLiteralPath p) = Text.pack p
     phi (NVEnvPath p)     = Text.pack p
+    phi (NVBuiltin1 _ _)    = error "Cannot coerce a function to a string"
+    phi (NVBuiltin2 _ _ _)  = error "Cannot coerce a function to a string"
 
 -- | Translate an atom into its nix representation.
 atomText :: NAtom -> Text
@@ -189,6 +195,15 @@ evalExpr = cata phi
                 arg <- x env
                 let arg' = buildArgument argset arg
                 f arg'
+            Fix (NVBuiltin1 _ f) -> do
+                arg <- x env
+                f arg
+            Fix (NVBuiltin2 name [] f) -> do
+                arg <- x env
+                pure $ Fix $ NVBuiltin2 name [arg] f
+            Fix (NVBuiltin2 _ [arg1] f) -> do
+                arg2 <- x env
+                f arg1 arg2
             _ -> error "Attempt to call non-function"
 
     phi (NAbs a b) = \env -> do

Nix/Pretty.hs

@@ -185,4 +185,6 @@ prettyNixValue = prettyNix . valueToExpr
         go (NVFunction p _) = NSym . pack $ ("<function with " ++ show (() <$ p)  ++ ">")
         go (NVLiteralPath fp) = NLiteralPath fp
         go (NVEnvPath p) = NEnvPath p
+        go (NVBuiltin1 name _) = NSym $ Text.pack $ "builtins." ++ name
+        go (NVBuiltin2 name _ _) = NSym $ Text.pack $ "builtins." ++ name
 

hnix.cabal

@@ -24,6 +24,7 @@ Library
   Exposed-modules:
     Nix.Atoms
     Nix.Eval
+    Nix.Builtins
     Nix.Parser
     Nix.Expr
     Nix.Pretty