Utils.hs

{- |
Module      : Language.Egison.Data.Utils
Licence     : MIT

This module provides some helper functions for handling Egison data.
-}

module Language.Egison.Data.Utils
  ( evalRef
  , evalObj
  , writeObjectRef
  , newEvaluatedObjectRef
  , tupleToRefs
  , tupleToListWHNF
  , tupleToList
  , makeTuple
  , makeITuple
  , pmIndices
  , updateHash
  ) where

import           Control.Monad
import           Control.Monad.State   (liftIO)
import           Control.Monad.Except            (throwError)

import           Data.IORef
import qualified Data.HashMap.Lazy               as HL

import           Language.Egison.Data
import           Language.Egison.IExpr


evalRef :: ObjectRef -> EvalM WHNFData
evalRef ref = do
  obj <- liftIO $ readIORef ref
  case obj of
    WHNF val -> return val
    Thunk thunk -> do
      val <- thunk
      writeObjectRef ref val
      return val

evalObj :: Object -> EvalM WHNFData
evalObj (WHNF val)    = return val
evalObj (Thunk thunk) = thunk

writeObjectRef :: ObjectRef -> WHNFData -> EvalM ()
writeObjectRef ref val = liftIO . writeIORef ref $ WHNF val

newEvaluatedObjectRef :: WHNFData -> EvalM ObjectRef
newEvaluatedObjectRef = liftIO . newIORef . WHNF

tupleToRefs :: WHNFData -> EvalM [ObjectRef]
tupleToRefs (ITuple refs)        = return refs
tupleToRefs (Value (Tuple vals)) = mapM (newEvaluatedObjectRef . Value) vals
tupleToRefs whnf                 = return <$> newEvaluatedObjectRef whnf

tupleToListWHNF :: WHNFData -> EvalM [WHNFData]
tupleToListWHNF (ITuple refs)        = mapM evalRef refs
tupleToListWHNF (Value (Tuple vals)) = return $ map Value vals
tupleToListWHNF whnf                 = return [whnf]

tupleToList :: EgisonValue -> [EgisonValue]
tupleToList (Tuple vals) = vals
tupleToList val          = [val]

makeTuple :: [EgisonValue] -> EgisonValue
makeTuple []  = Tuple []
makeTuple [x] = x
makeTuple xs  = Tuple xs

makeITuple :: [WHNFData] -> EvalM WHNFData
makeITuple []  = return (ITuple [])
makeITuple [x] = return x
makeITuple xs  = ITuple <$> mapM newEvaluatedObjectRef xs

pmIndices :: [Index (Maybe Var)] -> [Index EgisonValue] -> EvalM [Binding]
pmIndices [] [] = return []
pmIndices (MultiSub (Just a) s (Just e):xs) vs = do
  let (vs1, vs2) = span isSub vs
  let l = fromIntegral (length vs1)
  eRef <- newEvaluatedObjectRef (Value (toEgison l))
  let hash = (IIntHash HL.empty)
  hash <- foldM (\hash (i, v) -> updateHash [i] v hash) hash (zip [s..(s + l - 1)] (map (\(Sub v) -> Value v) vs1)) 
  aRef <- newEvaluatedObjectRef hash
  bs <- pmIndices xs vs2
  return ((a, aRef) : (e, eRef) : bs)
 where
  isSub (Sub _) = True
  isSub _       = False
pmIndices (MultiSup (Just a) s (Just e):xs) vs = do
  let (vs1, vs2) = span isSup vs
  let l = fromIntegral (length vs1)
  eRef <- newEvaluatedObjectRef (Value (toEgison l))
  let hash = (IIntHash HL.empty)
  hash <- foldM (\hash (i, v) -> updateHash [i] v hash) hash (zip [s..(s + l - 1)] (map (\(Sup v) -> Value v) vs1)) 
  aRef <- newEvaluatedObjectRef hash
  bs <- pmIndices xs vs2
  return ((a, aRef) : (e, eRef) : bs)
 where
  isSup (Sup _) = True
  isSup _       = False

pmIndices (x:xs) (v:vs) = do
  bs <- pmIndex x v
  bs' <- pmIndices xs vs
  return (bs ++ bs')
pmIndices _ _ = throwErrorWithTrace InconsistentTensorIndex

pmIndex :: Index (Maybe Var) -> Index EgisonValue -> EvalM [Binding]
pmIndex (Sub (Just var)) (Sub val) = do
  ref <- newEvaluatedObjectRef (Value val)
  return [(var, ref)]
pmIndex (Sup (Just var)) (Sup val) = do
  ref <- newEvaluatedObjectRef (Value val)
  return [(var, ref)]
pmIndex _ _ = throwErrorWithTrace InconsistentTensorIndex

updateHash :: [Integer] -> WHNFData -> WHNFData -> EvalM WHNFData
updateHash [index] tgt (IIntHash hash) = do
  targetRef <- newEvaluatedObjectRef tgt
  return . IIntHash $ HL.insert index targetRef hash
updateHash (index:indices) tgt (IIntHash hash) = do
  val <- maybe (return $ IIntHash HL.empty) evalRef $ HL.lookup index hash
  ref <- updateHash indices tgt val >>= newEvaluatedObjectRef
  return . IIntHash $ HL.insert index ref hash
updateHash indices tgt (Value (IntHash hash)) = do
  let keys = HL.keys hash
  vals <- mapM (newEvaluatedObjectRef . Value) $ HL.elems hash
  updateHash indices tgt (IIntHash $ HL.fromList $ zip keys vals)
updateHash _ _ v = throwError $ Default $ "expected hash value: " ++ show v