Move tracing code into its own file

hnix.cabal

@@ -2,7 +2,7 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: c030de7d44eabbd21ae044bd9108da5b34d7e3feaf8a8facbc9383c85e382186
+-- hash: aff8893297c028f78cd881c18224a6acbd05d797c4eb702bdcabcbb2341a0891
 
 name:           hnix
 version:        0.5.0
@@ -58,6 +58,7 @@ library
       Nix.StringOperations
       Nix.TH
       Nix.Thunk
+      Nix.Trace
       Nix.Type.Assumption
       Nix.Type.Env
       Nix.Type.Infer

src/Nix/Entry.hs

@@ -22,6 +22,7 @@ import qualified Data.Text.Read as Text
 import           Nix.Builtins
 import           Nix.Effects
 import qualified Nix.Eval as Eval
+import qualified Nix.Trace as Trace
 import           Nix.Expr.Shorthands
 import           Nix.Expr.Types (NExpr)
 import           Nix.Expr.Types.Annotated (NExprLoc, stripAnnotation)
@@ -74,7 +75,7 @@ tracingEvalLoc
     => Maybe FilePath -> NExprLoc -> m (NValue m)
 tracingEvalLoc mpath expr = do
     (expr', v) <- evalTopLevelExprGen id mpath
-        =<< Eval.tracingEvalExpr @_ @m @_ @(NValue m)
+        =<< Trace.tracingEvalExpr @_ @m @_ @(NValue m)
                 (Eval.eval @_ @(NValue m)
                            @(NThunk m) @m) expr
     liftIO $ do

src/Nix/Eval.hs

@@ -1,9 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -21,24 +18,19 @@
 
 module Nix.Eval where
 
-import           Control.Applicative
-import           Control.Arrow (first, second)
+import           Control.Arrow (first)
 import           Control.Monad
-import           Control.Monad.Catch
 import           Control.Monad.Fix
-import           Control.Monad.IO.Class
 import           Control.Monad.State
-import           Control.Monad.Trans.Reader
 import           Data.Align.Key
 import           Data.Fix
 import           Data.Functor.Compose
 import           Data.HashMap.Lazy (HashMap)
 import qualified Data.HashMap.Lazy as M
-import           Data.IORef
 import           Data.List (intercalate, partition, foldl')
 import           Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NE
-import           Data.Maybe (fromMaybe, catMaybes, mapMaybe)
+import           Data.Maybe (fromMaybe, catMaybes)
 import           Data.Text (Text)
 import qualified Data.Text as Text
 import           Data.These
@@ -54,7 +46,6 @@ import           Nix.StringOperations (runAntiquoted)
 import           Nix.Thunk
 import           Nix.Utils
 -- import           System.IO.Unsafe -- move this into a tracing module
-import           Text.Megaparsec.Pos
 
 class (Show v, Monad m) => MonadEval v m | v -> m where
     freeVariable :: Text -> m v
@@ -433,157 +424,6 @@ buildArgument e params arg = do
 
 -----
 
-newtype FlaggedF (f :: * -> *) r = FlaggedF { flagged :: (IORef Bool, f r) }
-    deriving (Functor, Foldable, Traversable)
-
-instance Show (f r) => Show (FlaggedF f r) where
-    show (FlaggedF (_, x)) = show x
-
--- instance Show (f r) => Show (FlaggedF f r) where
---     show (FlaggedF (b, x)) =
---         let !used = unsafePerformIO (readIORef b) in
---         if used
---         then show x
---         else "<<" ++ show x ++ ">>"
-
-type Flagged (f :: * -> *) = Fix (FlaggedF f)
-
-flagExprLoc :: MonadIO n => NExprLoc -> n (Flagged NExprLocF)
-flagExprLoc = cataM $ \x -> do
-    flag <- liftIO $ newIORef False
-    pure $ Fix $ FlaggedF (flag, x)
-
-stripFlags :: Flagged NExprLocF -> NExprLoc
-stripFlags = cata $ \(FlaggedF (_, x)) -> Fix x
-
-pruneTree :: MonadIO n => Flagged NExprLocF -> n (Maybe NExprLoc)
-pruneTree = cataM $ \(FlaggedF (b, Compose x)) -> do
-    used <- liftIO $ readIORef b
-    pure $ if used
-           then Just (Fix (Compose (fmap prune x)))
-           else Nothing
-  where
-    prune :: NExprF (Maybe NExprLoc) -> NExprF NExprLoc
-    prune = \case
-        NStr str                  -> NStr (pruneString str)
-        NHasAttr (Just aset) attr -> NHasAttr aset (NE.map pruneKeyName attr)
-        NList l                   -> NList (catMaybes l)
-        NSet binds                -> NSet (mapMaybe pruneBinding binds)
-        NRecSet binds             -> NRecSet (mapMaybe pruneBinding binds)
-        NAbs params (Just body)   -> NAbs (pruneParams params) body
-
-        NLet binds (Just body@(Fix (Compose (Ann _ x)))) ->
-            case mapMaybe pruneBinding (NE.toList binds) of
-                [] -> x
-                b:bs -> NLet (b:|bs) body
-
-        NSelect (Just aset) attr alt ->
-            NSelect aset (NE.map pruneKeyName attr) (join alt)
-
-        -- These are the only short-circuiting binary operators
-        NBinary NAnd (Just (Fix (Compose (Ann _ larg)))) Nothing -> larg
-        NBinary NOr  (Just (Fix (Compose (Ann _ larg)))) Nothing -> larg
-
-        -- If the scope of a with was never referenced, it's not needed
-        NWith Nothing (Just (Fix (Compose (Ann _ body)))) -> body
-
-        NAssert Nothing _ ->
-            error "How can an assert be used, but its condition not?"
-
-        NAssert _ (Just (Fix (Compose (Ann _ body)))) -> body
-
-        NIf Nothing _ _ ->
-            error "How can an if be used, but its condition not?"
-
-        NIf _ Nothing (Just (Fix (Compose (Ann _ f)))) -> f
-        NIf _ (Just (Fix (Compose (Ann _ t)))) Nothing -> t
-
-        x -> fromMaybe nNull <$> x
-
-    pruneString :: NString (Maybe NExprLoc) -> NString NExprLoc
-    pruneString (DoubleQuoted xs) =
-        DoubleQuoted (mapMaybe pruneAntiquotedText xs)
-    pruneString (Indented n xs)   =
-        Indented n (mapMaybe pruneAntiquotedText xs)
-
-    pruneAntiquotedText
-        :: Antiquoted Text (Maybe NExprLoc)
-        -> Maybe (Antiquoted Text NExprLoc)
-    pruneAntiquotedText (Plain v)             = Just (Plain v)
-    pruneAntiquotedText EscapedNewline        = Just EscapedNewline
-    pruneAntiquotedText (Antiquoted Nothing)  = Nothing
-    pruneAntiquotedText (Antiquoted (Just k)) = Just (Antiquoted k)
-
-    pruneAntiquoted
-        :: Antiquoted (NString (Maybe NExprLoc)) (Maybe NExprLoc)
-        -> Maybe (Antiquoted (NString NExprLoc) NExprLoc)
-    pruneAntiquoted (Plain v)             = Just (Plain (pruneString v))
-    pruneAntiquoted EscapedNewline        = Just EscapedNewline
-    pruneAntiquoted (Antiquoted Nothing)  = Nothing
-    pruneAntiquoted (Antiquoted (Just k)) = Just (Antiquoted k)
-
-    pruneKeyName :: NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc
-    pruneKeyName (StaticKey n p) = StaticKey n p
-    pruneKeyName (DynamicKey k)
-        | Just k' <- pruneAntiquoted k = DynamicKey k'
-        | otherwise = StaticKey "unused" Nothing
-
-    pruneParams :: Params (Maybe NExprLoc) -> Params NExprLoc
-    pruneParams (Param n) = Param n
-    pruneParams (ParamSet xs b n) = ParamSet (map (second join) xs) b n
-
-    pruneBinding :: Binding (Maybe NExprLoc) -> Maybe (Binding NExprLoc)
-    pruneBinding (NamedVar _ Nothing)  = Nothing
-    pruneBinding (NamedVar xs (Just x)) =
-        Just (NamedVar (NE.map pruneKeyName xs) x)
-    pruneBinding (Inherit _ [])  = Nothing
-    pruneBinding (Inherit m xs)  =
-        Just (Inherit (join m) (map pruneKeyName xs))
-
-nNull :: Fix (Compose (Ann SrcSpan) NExprF)
-nNull = Fix (Compose (Ann (SrcSpan nullPos nullPos) (NConstant NNull)))
-  where
-    nullPos = SourcePos "<unknown>" (mkPos 0) (mkPos 0)
-
-tracingEvalExpr :: (Framed e m, MonadIO m,
-                   MonadCatch n, MonadIO n, Alternative n)
-                => (NExprF (m v) -> m v) -> NExprLoc -> n (m (NExprLoc, v))
-tracingEvalExpr eval expr = do
-    expr' <- flagExprLoc expr
-    res <- flip catch handle $ flip runReaderT (0 :: Int) $
-        adiM (pure <$> eval . annotated . getCompose . snd . flagged)
-             psi expr'
-    return $ do
-        v <- res
-        expr'' <- pruneTree expr'
-        return (fromMaybe nNull expr'', v)
-  where
-    handle err = error $ "Error during evaluation: "
-        ++ show (err :: SomeException)
-
-    psi k v@(Fix (FlaggedF (b, x))) = do
-        depth <- ask
-        guard (depth < 200)
-        local succ $ do
-            action <- k v
-            -- action <- k =<< case x of
-            --     Compose (Ann appAnn
-            --              (NBinary NApp
-            --               (Fix (FlaggedF
-            --                     (impBool,
-            --                      Compose (Ann impAnn
-            --                               (NSym "import")))))
-            --                  appArg)) -> do
-            --         pure $ Fix (FlaggedF (b, error "import detected"))
-            --     _ -> pure v
-            return $ withExprContext (stripFlags v) $ do
-                traceM $ "eval: " ++ replicate (depth * 2) ' '
-                    ++ show (stripAnnotation (stripFlags v))
-                liftIO $ writeIORef b True
-                res <- action
-                traceM $ "eval: " ++ replicate (depth * 2) ' ' ++ "."
-                return res
-
 framedEvalExpr :: Framed e m => (NExprF (m v) -> m v) -> NExprLoc -> m v
 framedEvalExpr eval = adi (eval . annotated . getCompose) psi
   where