{-# OPTIONS_GHC -fglasgow-exts #-}

module PIL.Native.Coerce where
import PIL.Native.Types
import Control.Arrow
import Control.Exception
import Data.Dynamic
import Data.Typeable
import Data.ByteString.Base (ByteString(..))
import qualified Data.Map as Map
import qualified Data.Seq as Seq
import qualified Data.ByteString.Char8 as Str

{-| 

PIL.Native.Coerce

This module defines the functions for use with the types defined 
in PIL.Native.Types. 

See Also: 

  PIL.Native.Types
  PIL.Native.Prims

-}

nil :: Native
nil = toNative mkNil

is_nil :: Native -> Bool
is_nil (NError {})  = True
is_nil _            = False

emptySeq :: Native
emptySeq = toNative (empty :: NativeSeq)

emptyMap :: Native
emptyMap = toNative (empty :: NativeMap)

mkNil :: NativeError
mkNil = NonTermination

mkErr :: (Typeable a) => a -> NativeError
mkErr = DynException . toDyn

mkSeq :: [b] -> SeqOf b
mkSeq = Seq.fromList

mkMap :: [(String, a)] -> MapOf a
mkMap = Map.fromList . map (\(k, v) -> (mkStr k, v))

mkStr :: String -> NativeStr
mkStr = Str.pack

mkSub :: [String] -> [NativeLangExpression] -> NativeSub
mkSub params exps = MkSub
    { s_params = mkSeq (map mkStr params)
    , s_exps   = mkSeq exps
    , s_pad    = empty
    }

class IsPlural a key val | a -> key, a -> val where 
    isEmpty     :: a -> NativeBit
    size        :: a -> NativeInt
    reversed    :: a -> a
    exists      :: a -> key -> Bool
    empty       :: a
    indices     :: a -> [key]
    elems       :: a -> [val]
    append      :: a -> a -> a
    push        :: a -> SeqOf val -> a
    assocs      :: a -> [(key, val)]
    fromAssocs  :: [(key, val)] -> a
    splice      :: a -> Int -> a
    fetch       :: a -> key -> Maybe val
    insert      :: a -> key -> val -> a
    delete      :: a -> key -> a
    (!)         :: a -> key -> val
    (!) x k = maybe (error "index out of bounds") id $ fetch x k

instance IsPlural NativeStr NativeInt NativeStr where
    isEmpty    = Str.null
    size       = Str.length
    empty      = Str.empty
    exists (PS _ _ l) n = (n >= 0) && (n < l)
    indices    = \x -> [0 .. (Str.length x - 1)]
    elems (PS _ _ 0) = []
    elems (PS x s l) = (PS x s 1:elems (PS x (s+1) (l-1)))
    {-# INLINE elems #-}
    append     = Str.append
    reversed   = Str.reverse
    push       = \x xs -> Str.concat (x:Seq.toList xs)
    assocs     = zip [0..] . elems
    fromAssocs = Str.concat . map snd -- XXX wrong
    splice     = flip Str.drop
    fetch (PS p s l) n
        | n < 0     = fail "negative index"
        | n >= l    = fail "index out of bounds"
        | otherwise = return $ PS p (s + n) 1
    delete     = error "It doesn't make sense to delete from a string"
    insert     = error "XXX str.insert"

instance (Ord k, Show k) => IsPlural (Map.Map k v) k v where
    isEmpty    = Map.null
    size       = Map.size
    empty      = Map.empty
    indices    = Map.keys
    elems      = Map.elems
    exists     = flip Map.member
    append     = Map.union
    push       = error "It doesn't make sense to push into a hash"
    splice     = error "It doesn't make sense to splice from a hash"
    reversed   = error "It doesn't make sense to reverse from a hash"
    assocs     = Map.assocs
    fromAssocs = Map.fromList
    fetch      = flip Map.lookup
    delete     = flip Map.delete    
    insert     = \o k v -> Map.insert k v o
    (!) x k    = case Map.lookup k x of
        Just v  -> v
        Nothing -> error $ "Cannot find " ++ show k ++ " in map: " ++ show (indices x)

instance IsPlural (SeqOf a) NativeInt a where
    isEmpty      = Seq.null
    size         = Seq.length
    empty        = Seq.empty
    exists x n   = (n >= 0) && (n < size x)
    indices      = \x -> [0 .. size x - 1]
    elems        = Seq.toList
    append       = (Seq.><)
    push         = append
    reversed     = Seq.reverse
    splice       = flip Seq.drop
    assocs       = ([0..] `zip`) . elems
    fromAssocs   = Seq.fromList . map snd -- XXX wrong
    fetch x k    | k >= size x = Nothing
                 | otherwise   = Just (Seq.index x k)
    insert x k v | k == size x = (Seq.|>) x v
                 | otherwise   = Seq.update k v x
    delete       = error "It doesn't make sense to delete from an array"                 
    (!)          = Seq.index

class Show a => IsNative a where 
    toNative   :: a -> Native
    fromNative :: Native -> a
    toString   :: a -> String
    toString   = show

instance IsNative Native where
    toNative   = id
    fromNative = id
    toString (NError x)   = toString x
    toString (NBit x)     = toString x
    toString (NInt x)     = toString x
    toString (NNum x)     = toString x
    toString (NStr x)     = toString x
    toString (NSeq x)     = toString x
    toString (NMap x)     = toString x
    toString x            = castFail x

instance IsNative NativeBit where
    toNative = NBit
    fromNative (NError {})  = False      -- Errors are undefs are false
    fromNative (NBit x)     = x
    fromNative (NInt x)     = (x /= 0)
    fromNative (NNum x)     = (x /= 0)
    fromNative (NStr x)     = case size x of
        0   -> False
        1   -> (Str.head x /= '0')
        _   -> True
    fromNative (NSeq x)     = isEmpty x
    fromNative (NMap x)     = isEmpty x
    fromNative (NSub _)     = True
    fromNative (NObj _)     = True

instance IsNative NativeInt where
    toNative = NInt
    fromNative (NError {})  = 0
    fromNative (NBit x)     = fromEnum x
    fromNative (NInt x)     = x
    fromNative (NNum x)     = fromEnum x
    fromNative (NStr x)     = read (toString x)
    fromNative (NSeq x)     = size x
    fromNative (NMap x)     = size x
    fromNative x            = castFail x

instance IsNative NativeStr where
    toNative = NStr
    toString = Str.unpack -- unpackFromUTF8
    fromNative (NError {})  = empty
    fromNative (NBit x)     = if x then mkStr "1" else mkStr "0"
    fromNative (NInt x)     = mkStr $ toString x
    fromNative (NNum x)     = mkStr $ toString x
    fromNative (NStr x)     = x
    fromNative (NSeq x)     = Str.unwords $ map fromNative (elems x)
    fromNative (NMap x)     = Str.unlines $ map fromPair (assocs x)
        where
        fromPair (k, v) = Str.append k (Str.cons '\t' (fromNative v))
    fromNative x            = castFail x

instance IsNative NativeNum where
    toNative = NNum
    fromNative (NError {})  = 0
    fromNative (NBit x)     = if x then 1 else 0
    fromNative (NInt x)     = toEnum x
    fromNative (NNum x)     = x
    fromNative (NStr x)     = read (toString x)
    fromNative (NSeq x)     = toEnum (size x)
    fromNative (NMap x)     = toEnum (size x)
    fromNative x            = castFail x

instance IsNative NativeMap where
    toNative = NMap
    fromNative (NError {})  = empty
    fromNative (NMap x)     = x
    fromNative (NSeq x)     = Map.fromList (roll (Seq.toList x))
        where
        roll [] = []
        roll [_] = error "odd number of hash elements"
        roll (k:v:xs) = ((fromNative k, v):roll xs)
    fromNative x            = castFail x

instance IsNative NativeSub where
    toNative = NSub
    fromNative (NSub x)     = x
    fromNative x            = castFail x

instance IsNative NativeObj where
    toNative = NObj
    fromNative (NObj x)     = x
    fromNative x            = castFail x

instance IsNative NativeError where
    toNative = NError
    fromNative (NError x)   = x
    fromNative x            = mkErr x

instance IsNative Integer where
    toNative = toNative . fromEnum
    fromNative = toEnum . fromNative

instance IsNative Double where
    toNative = (toNative :: NativeNum -> Native) . uncurry encodeFloat . decodeFloat
    fromNative = uncurry encodeFloat . decodeFloat . (fromNative :: Native -> NativeNum)

instance IsNative (Either Integer Double) where
    toNative = either toNative toNative
    fromNative (NNum x) = (Right . uncurry encodeFloat . decodeFloat) x
    fromNative n        = (Left . fromNative) n

instance IsNative String where
    toNative = toNative . mkStr
    fromNative = Str.unpack . fromNative -- unpackFromUTF8 . fromNative

instance IsNative [Native] where
    toNative = NSeq . mkSeq
    fromNative = Seq.toList . (fromNative :: Native -> NativeSeq)

instance IsNative [(Native, Native)] where
    toNative = NMap . Map.fromList . map ((fromNative :: Native -> NativeStr) *** id) 
    fromNative = Map.assocs . Map.mapKeys (toNative :: NativeStr -> Native) . fromNative

instance IsNative [NativeStr] where
    toNative = (toNative :: NativeSeq -> Native) . mkSeq . map toNative
    fromNative = map fromNative . fromNative

instance (IsNative a) => IsNative (Maybe a) where
    toNative Nothing  = nil
    toNative (Just x) = toNative x
    fromNative (NError {}) = Nothing
    fromNative x           = Just (fromNative x)

instance (IsNative a) => IsNative (SeqOf a) where
    toNative = NSeq . fmap toNative
    fromNative (NError {})  = empty
    fromNative (NSeq x)     = fmap fromNative x
    fromNative (NMap x)     = mkSeq (fmap fromNative (unroll (Map.toAscList x)))
        where
        unroll [] = []
        unroll ((k, v):xs) = (toNative k:v:unroll xs)
    fromNative x            = castFail x

instance IsNative () where
    toNative () = nil
    fromNative (NError {}) = ()
    fromNative x = castFail x

instance IsNative [NativeObj] where
    toNative = NSeq . mkSeq . map toNative
    fromNative (NError {})  = []
    fromNative (NSeq x)     = elems $ fmap fromNative x
    fromNative x            = castFail x

castFail :: a -> b
castFail _ = error "cast fail"

failWith :: (Monad m, IsNative a) => String -> a -> m b
failWith msg s = fail $ msg ++ ": " ++ toString s