{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Nix.Builtins (baseEnv, builtins,
                     Cyclic(..), evalTopLevelExpr, evalTopLevelExprIO) where

import           Control.Monad.Fix
import           Control.Monad.IO.Class
import           Control.Monad.Trans.State
import           Data.Fix
import           Data.Functor.Identity
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           Nix.Parser
import           System.IO.Unsafe

-- | Evaluate a nix expression in the default context
evalTopLevelExpr :: MonadNix m => NExpr -> m (NValue m)
evalTopLevelExpr val = newScope baseEnv (evalExpr val)

baseEnv :: MonadNix m => ValueSet m
baseEnv = fmap pure . Map.fromList $
    ("builtins", Fix $ NVSet builtins) : topLevelBuiltins
  where
    topLevelBuiltins = map mapping $ filter isTopLevel builtinsList
    -- builtins = Map.fromList $ map mapping $ builtinsList


newtype Cyclic m a = Cyclic { runCyclic :: StateT (ValueSet (Cyclic m)) m a }
    deriving (Functor, Applicative, Monad, MonadFix)

instance MonadNix (Cyclic Identity) where
    currentScope = Cyclic get
    newScope s k = Cyclic $ put s >> runCyclic k
    importFile path = Cyclic $ case path of
        Fix (NVLiteralPath path) ->
            let eres = unsafePerformIO $ parseNixFile path
            in case eres of
                Failure err  -> error $ "Parse failed: " ++ show err
                Success expr -> runCyclic $ evalExpr expr
        _ -> error $ "Unexpected argument to import: " ++ show path

instance MonadNix (Cyclic IO) where
    currentScope = Cyclic $ do
        liftIO $ putStrLn "Getting env..."
        res <- get
        liftIO $ putStrLn "Getting env...done"
        return res
    newScope s k = Cyclic $ do
        liftIO $ putStrLn "Setting env..."
        put s
        liftIO $ putStrLn "Setting env...done"
        runCyclic k
    importFile path = Cyclic $ case path of
        Fix (NVLiteralPath path) -> do
            liftIO $ putStrLn $ "Importing file: " ++ path
            eres <- parseNixFile path
            case eres of
                Failure err  -> error $ "Parse failed: " ++ show err
                Success expr -> runCyclic $ evalExpr expr
        _ -> error $ "Unexpected argument to import: " ++ show path

evalTopLevelExprIO :: NExpr -> IO (NValue (Cyclic IO))
evalTopLevelExprIO expr =
    evalStateT (runCyclic (evalTopLevelExpr expr)) Map.empty

builtins :: MonadNix m => Map.Map Text (NValue 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 :: MonadNix m => [ Builtin m ]
builtinsList = [
      topLevel ("toString", prim_toString)
    , topLevel ("import"  , prim_import)
    , 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 :: MonadNix m => NValue m -> NValue m -> m (NValue m)
evalPred (Fix (NVFunction params pred)) arg = do
    args <- buildArgument params arg
    newScope args pred
evalPred pred _ = error $ "Trying to call a " ++ show pred


-- Primops

prim_toString :: MonadNix m => Functor m => NValue m
prim_toString = builtin "toString" toString
toString :: MonadNix m => NValue m -> m (NValue m)
toString s = return $ Fix $ uncurry NVStr $ valueText s

prim_import :: MonadNix m => Functor m => NValue m
prim_import = builtin "import" import_
import_ :: MonadNix m => NValue m -> m (NValue m)
import_ = importFile

prim_hasAttr :: MonadNix m => NValue m
prim_hasAttr = builtin2 "hasAttr" hasAttr
hasAttr :: MonadNix 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 :: MonadNix m => NValue m
prim_getAttr = builtin2 "getAttr" getAttr
getAttr :: MonadNix 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 :: MonadNix m => NValue m
prim_any = builtin2 "any" _any
_any :: MonadNix 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 :: MonadNix m => NValue m
prim_all = builtin2 "all" _all
_all :: MonadNix 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