{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, 
NoMonomorphismRestriction, FlexibleContexts, ExistentialQuantification, 
FunctionalDependencies, ScopedTypeVariables, UndecidableInstances,
TypeOperators, IncoherentInstances #-}

{- Code / Term Interpretations for Data and Loop -}

module Value(Value(..), MValue(..), value) where

import StateCont
import Control.Monad
import Control.Monad.Identity
import Control.Monad.ST
import Data.Array.ST
import Data.Array.MArray
import Data.Array.Base
import Prelude hiding (div)
import Struct
import Data
import Control
import Array
import Term -- FIXME: his has Value
            
{-
   Interpret Data as pure functions.  The existence of this
   interpretation guarantees the Monad used for implementing the binding
   structure is well-behaved. 

   To use, pass an expression that produces a single value to the
   function `eval'.

-} 
              
{- Value, MValue, SValue come in a pair.  Currently this is just the
identity monad, and a dummy syntax data type.  The monad will probably
be a variant of ST to accomodate mutable arrays. -}

data MValue t = MValue t deriving (Show, Eq)
instance Monad MValue where
  return = MValue
  (>>=) (MValue v) f = f v
  
{- Dummy syntax type.  Not used for Value -}
data SValue  
  
-- Main interface for functional part (Control / Data).
type Ev t = MValue (Value t)  
value :: Ev t -> t
value (MValue (Value v)) = v
     

v2op op (Value a) (Value b) = return $ Value $ a `op` b

instance Repr Value

instance DataRing MValue Value Tfloat where 
  add = v2op (+)
  sub = v2op (-)
  mul = v2op (*)
  eq  = v2op (==)
  lt  = v2op (<)
  lit = return . Value  

instance DataField MValue Value Tfloat where 
  div = v2op (/)

instance DataRing MValue Value Tint where 
  add = v2op (+)
  sub = v2op (-)
  mul = v2op (*)
  
  eq  = v2op (==)
  lt  = v2op (<)
   
  lit = return . Value
  
instance Data MValue Value where              
  true  = return $ Value True
  false = return $ Value False
  f2i = undefined
  i2f = undefined
  
  unpack rs = return $ unrepStruct rs
  pack   sr = return $ repStruct   sr


instance StructRepr Value where
  
  rep2 (Value a, Value b) = Value (a, b)
  rep1 (L (Value a))      = Value (L a)
  rep0  ()                 = Value ()
  
  unrep2 (Value (a, b)) = (Value a, Value b)
  unrep1 (Value (L a))  = L (Value a)
  unrep0 (Value ())     = ()

-- The non-functional part needs a non-trivial monad to implement
-- array updates and sequencing.
instance (DataWord t, MArray a t MValue) => Array MValue Value (a Int) t where
  get (Value a) (Value i) =           liftM Value $ readArray a i
  set (Value a) (Value i) (Value e) = liftM Value $ writeArray a i e
 

instance Control MValue Value where
  ifte (Value v) a b = if v then a else b
  ret = return
  
  -- The monadic version of:
  --   _letrec open body = body fix where
  --      fix = open fix
  letrec open body = app body mfix where
    mfix = app open mfix
    app f mfix = do {fix <- mfix ; f fix}


  -- Application and abstraction use structures to pass arguments.
  app rf ras = app' rf (repStruct ras) where
    app' (Value f) (Value as) = 
      liftM Value $ f as
  lam f = return $ Value rf where
    rf as = do
      Value t <- f $ unrepStruct $ Value as
      return t
      
  -- Definitions don't make much sense in Value rep with the current
  -- MValue monad..
  def _ _ = return $ Value ()    



-- Variable generation is not used for Value representation
niValue f = error $ f ++ " not implemented for Value representation"
instance DataWord t 
         => StructVar (L (Value t)) where
  structVar = niValue "StructVar"