<commit_before>{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module Language.K3.Interpreter.Utils where

import Control.Applicative
import Control.Arrow
import Control.Concurrent.MVar
import Control.Monad.State

import Data.Function
import Data.List
import qualified Data.HashTable.IO as HT 

import Language.K3.Core.Annotation
import Language.K3.Core.Common
import Language.K3.Core.Type

import Language.K3.Interpreter.Data.Types
import Language.K3.Interpreter.Data.Accessors

import Language.K3.Runtime.Engine

import Language.K3.Utils.Pretty
import Language.K3.Utils.Logger

$(loggingFunctions)
$(customLoggingFunctions ["Dispatch", "BindPath"])

{- Misc. helpers-}
-- | Matches polymorphic and monomorphic functions.
isFunction :: K3 Type -> Bool
isFunction (tag -> TFunction) = True
isFunction (tag &&& children -> (TForall _, [t])) = isFunction t
isFunction _ = False


{- Pretty printing -}

prettyIEnvEntry :: IEnvEntry Value -> EngineM Value String
prettyIEnvEntry (IVal v)  = return $ pretty v
prettyIEnvEntry (MVal mv) = liftIO (readMVar mv) >>= return . pretty

prettyIEnvM :: IEnvironment Value -> EngineM Value [String]
prettyIEnvM env = do
    nWidth   <- return . maximum . map (length . fst) =<< liftIO (HT.toList env)
    bindings <- mapM (prettyEnvEntries nWidth) . sortBy (compare `on` fst) =<< liftIO (HT.toList env)
    return $ concat bindings 
  where 
    prettyEnvEntries w (n, eel) = do
      sl <- mapM prettyIEnvEntry eel
      return . concat $ map (shift (prettyName w n) (prefixPadTo (w+4) " .. ") . wrap 70) sl

    prettyName w n    = (suffixPadTo w n) ++ " => "
    suffixPadTo len n = n ++ replicate (max (len - length n) 0) ' '
    prefixPadTo len n = replicate (max (len - length n) 0) ' ' ++ n

prettyIStateM :: IState -> EngineM Value [String]
prettyIStateM st = do
  envLines <- prettyIEnvM $ getEnv st
  return $ ["Environment:"] ++ (indent 2 $ envLines)
        ++ ["Annotations:"] ++ (indent 2 $ lines $ show $ getAnnotEnv st)<commit_msg>Prevent pretty printing from extracting list out of hashtable twice<commit_after>{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module Language.K3.Interpreter.Utils where

import Control.Applicative
import Control.Arrow
import Control.Concurrent.MVar
import Control.Monad.State

import Data.Function
import Data.List
import qualified Data.HashTable.IO as HT 

import Language.K3.Core.Annotation
import Language.K3.Core.Common
import Language.K3.Core.Type

import Language.K3.Interpreter.Data.Types
import Language.K3.Interpreter.Data.Accessors

import Language.K3.Runtime.Engine

import Language.K3.Utils.Pretty
import Language.K3.Utils.Logger

$(loggingFunctions)
$(customLoggingFunctions ["Dispatch", "BindPath"])

{- Misc. helpers-}
-- | Matches polymorphic and monomorphic functions.
isFunction :: K3 Type -> Bool
isFunction (tag -> TFunction) = True
isFunction (tag &&& children -> (TForall _, [t])) = isFunction t
isFunction _ = False


{- Pretty printing -}

prettyIEnvEntry :: IEnvEntry Value -> EngineM Value String
prettyIEnvEntry (IVal v)  = return $ pretty v
prettyIEnvEntry (MVal mv) = liftIO (readMVar mv) >>= return . pretty

prettyIEnvM :: IEnvironment Value -> EngineM Value [String]
prettyIEnvM env = do
    env_list <- liftIO $ HT.toList env
    let nWidth = maximum $ map (length . fst) env_list
        sorted_env = sortBy (compare `on` fst) env_list
    bindings <- mapM (prettyEnvEntries nWidth) sorted_env
    return $ concat bindings 
  where 
    prettyEnvEntries w (n, eel) = do
      sl <- mapM prettyIEnvEntry eel
      return . concat $ map (shift (prettyName w n) (prefixPadTo (w+4) " .. ") . wrap 70) sl

    prettyName w n    = (suffixPadTo w n) ++ " => "
    suffixPadTo len n = n ++ replicate (max (len - length n) 0) ' '
    prefixPadTo len n = replicate (max (len - length n) 0) ' ' ++ n

prettyIStateM :: IState -> EngineM Value [String]
prettyIStateM st = do
  envLines <- prettyIEnvM $ getEnv st
  return $ ["Environment:"] ++ (indent 2 $ envLines)
        ++ ["Annotations:"] ++ (indent 2 $ lines $ show $ getAnnotEnv st)
{'fraction_non_alphanumeric': 0.11952191235059761, 'fraction_numerical': 0.00796812749003984, 'mean_word_length': 3.7901234567901234, 'pattern_counts': {'":': 0, '<': 15, '<?xml version=': 0, '>': 21, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6523278', 'n_tokens_mistral': 1450, 'n_tokens_neox': 1385, 'n_words': 412}