module Grin.Val(
    FromVal(..),
    ToVal(..),
    tn_2Tup,
    valToList,
    cChar,
    cWord,
    cInt,
    convertName,
    region_heap,
    region_atomic_heap,
    region_stack,
    region_block
    ) where

import Data.Char

import Cmm.Number
import Grin.Grin
import Name.Name
import Name.Names
import Name.VConsts
import StringTable.Atom

nil      = convertName dc_EmptyList
cons     = convertName dc_Cons
cChar    = convertName dc_Char
cWord    = convertName dc_Word
cInt     = convertName dc_Int
tn_2Tup  = convertName $ nameTuple DataConstructor 2
tn_Boolzh = convertName dc_Boolzh
tn_unit  = convertName dc_Unit

-- This allocates data on the heap.
region_heap  = Item (toAtom "heap") TyRegion
-- This allocates data on the atomic heap.
region_atomic_heap  = Item (toAtom "atomicHeap") TyRegion
-- This allocates data in the innermost enclosing region, including implicit regions.
region_block = Item (toAtom "block") TyRegion
-- This allocates data on the stack, generally equivalent to 'block' for most back ends.
region_stack = Item (toAtom "stack") TyRegion

instance ConNames Val where
    vTrue  = NodeC tn_Boolzh [toUnVal (1 :: Int)]
    vFalse = NodeC tn_Boolzh [toUnVal (0 :: Int)]
    vUnit  = NodeC tn_unit []

class ToVal a where
    toVal :: a -> Val
    toUnVal :: a -> Val
    toUnVal x = toVal x

class FromVal a where
    fromVal :: Monad m => Val -> m a
    fromUnVal :: Monad m => Val -> m a
    fromUnVal x = fromVal x

instance ToVal Bool where
    toVal True = vTrue
    toVal False = vFalse

instance ToVal a => ToVal [a] where
    toVal [] = NodeC nil []
    toVal (x:xs) =  NodeC cons [Const (toVal x),Const (toVal xs)]
instance  ToVal (Val,Val) where
    toVal (x,y) = NodeC tn_2Tup [x,y]

instance ToVal Char where
    toVal c = NodeC cChar [toUnVal c]
    toUnVal c =   Lit (fromIntegral $ ord c) tIntzh
instance ToVal Int where
    toVal c = NodeC cInt [toUnVal c]
    toUnVal c =  Lit (fromIntegral c) tIntzh

instance ToVal Val where
    toVal x = x

instance FromVal Int where
    fromVal (NodeC _ [Lit i _]) | Just x <- toIntegral i = return x
    fromVal n = fail $ "Val is not Int: " ++ show n
    fromUnVal (Lit i _) | Just x <- toIntegral i = return x
    fromUnVal n = fail $ "Val is not UnInt: " ++ show n
instance FromVal Char where
    fromVal (NodeC _ [Lit i _]) | Just x <- toIntegral i, x >= ord minBound && x <= ord maxBound = return (chr x)
    fromVal n = fail $ "Val is not Char: " ++ show n
    fromUnVal (Lit i _) | Just x <- toIntegral i, x >= ord minBound && x <= ord maxBound = return (chr x)
    fromUnVal n = fail $ "Val is not UnChar: " ++ show n

instance FromVal a => FromVal [a] where
    fromVal (NodeC n [])  | n == nil = return []
    fromVal (NodeC n [Const a,Const b]) | n == cons = do
        x <- fromVal a
        xs <- fromVal b
        return (x:xs)
    fromVal n = fail $ "Val is not [a]: " ++ show n

instance FromVal Bool  where
    fromVal n
        | n == toVal True = return True
        | n == toVal False = return False
    fromVal n = fail $ "Val is not Bool: " ++ show n
instance FromVal Val where
    fromVal n = return n

valToList (NodeC n []) | n == nil = return []
valToList (NodeC n [a,Const b]) | n == cons = do
        xs <- valToList b
        return (a:xs)
valToList n = fail $ "Val is not [a]: " ++ show n

convertName n = toAtom (t':s) where
    (t,s) = fromName n
    t' | t == TypeConstructor = 'T'
       | t == DataConstructor = 'C'
       | t == Val = 'f'
       | otherwise = error $ "convertName: " ++ show (t,s)