module Data.PHPSession.ImplicitConv.PHPTypeCoercion (
convFromPHPImplicit,
convFromPHPImplicitSafe,
ConversionFromPHPImplicitValueOrMismatch(..)
) where
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.ByteString.Char8 as BS
import Data.PHPSession.Types
import Data.PHPSession.ImplicitConv.ConvBool
import Data.Int (Int32, Int64)
import Data.List as L (foldl')
import Data.PHPSession.Conv
class ConversionFromPHPImplicitValueOrMismatch b where
convFromPHPImplicitOM :: PHPSessionValue -> Either String b
isScalarForArray v =
case v of
PHPSessionValueBool _ -> True
PHPSessionValueFloat _ -> True
PHPSessionValueInt _ -> True
PHPSessionValueString _ -> True
PHPSessionValueNull -> False
PHPSessionValueObjectSerializeable _ _ -> False
PHPSessionValueMisc _ _ -> False
PHPSessionValueObject _ _ -> False
PHPSessionValueArray _ -> False
instance ConversionFromPHPImplicitValueOrMismatch [(PHPSessionValue,PHPSessionValue)] where
convFromPHPImplicitOM v | isScalarForArray v = arrayScalarAsValue v
convFromPHPImplicitOM (PHPSessionValueObject _cls arr) = Right arr
convFromPHPImplicitOM (PHPSessionValueArray arr) = Right arr
convFromPHPImplicitOM v = mismatchError v "[(PHPSessionValue,PHPSessionValue)]"
arrayScalarAsValue :: PHPSessionValue -> Either String [(PHPSessionValue,PHPSessionValue)]
arrayScalarAsValue r =
Right ([(PHPSessionValueInt 0, r)])
convArrayScalarLeftSide :: ConversionFromPHPImplicitValueOrMismatch a => PHPSessionValue -> Either String [(a,PHPSessionValue)]
convArrayScalarLeftSide r =
case convFromPHPImplicitOM (PHPSessionValueInt 0) of
Left message -> Left message
Right index ->
Right ([(index, r)])
convArrayListLeftSide :: ConversionFromPHPImplicitValueOrMismatch a => [(PHPSessionValue,PHPSessionValue)] -> Either String [(a,PHPSessionValue)]
convArrayListLeftSide vars =
case L.foldl' ontoTuple (Right []) vars of
Left str -> Left str
Right lst -> Right $ reverse lst
where
ontoTuple (Left str) _ = Left str
ontoTuple (Right lst) (l,r) =
let l' = convFromPHPImplicitOM l
in case l' of
Left errl -> Left errl
Right l'' ->
Right ((l'',r) : lst)
instance ConversionFromPHPImplicitValueOrMismatch b => ConversionFromPHPImplicitValueOrMismatch [(PHPSessionValue,b)] where
convFromPHPImplicitOM v | isScalarForArray v = convArrayScalarRightSide v convFromPHPImplicitOM
convFromPHPImplicitOM (PHPSessionValueObject _cls arr) = convArrayListRightSide arr convFromPHPImplicitOM
convFromPHPImplicitOM (PHPSessionValueArray arr) = convArrayListRightSide arr convFromPHPImplicitOM
convFromPHPImplicitOM v = mismatchError v "ConversionFromPHPValueOrMismatch b => ConversionFromPHPValueOrMismatch [(PHPSessionValue,b)]"
convArrayScalarRightSide r conv =
case conv r of
Left message -> Left message
Right r' -> Right ([(PHPSessionValueInt 0, r')])
convArrayListRightSide vars conv =
case L.foldl' ontoTuple (Right []) vars of
Left str -> Left str
Right lst -> Right $ reverse lst
where
ontoTuple (Left str) _ = Left str
ontoTuple (Right lst) (l,r) =
case conv r of
Left errr -> Left errr
Right r'' ->
Right $ (l,r'') : lst
instance (ConversionFromPHPImplicitValueOrMismatch a, ConversionFromPHPImplicitValueOrMismatch b) => ConversionFromPHPImplicitValueOrMismatch [(a,b)] where
convFromPHPImplicitOM v | isScalarForArray v = convArrayScalarBothSides v convFromPHPImplicitOM
convFromPHPImplicitOM (PHPSessionValueObject _cls arr) = convArrayListBothSides arr convFromPHPImplicitOM
convFromPHPImplicitOM (PHPSessionValueArray arr) = convArrayListBothSides arr convFromPHPImplicitOM
convFromPHPImplicitOM v = mismatchError v "(ConversionFromPHPValueOrMismatch a, ConversionFromPHPValueOrMismatch b) => ConversionFromPHPValueOrMismatch [(a,b)]"
convArrayScalarBothSides
:: ConversionFromPHPImplicitValueOrMismatch t1 =>
t -> (t -> Either String t2) -> Either String [(t1, t2)]
convArrayScalarBothSides r conv =
case convFromPHPImplicitOM (PHPSessionValueInt 0) of
Left message -> Left message
Right index ->
case conv r of
Left message' -> Left message'
Right r' -> Right ([(index, r')])
convArrayListBothSides vars conv =
case L.foldl' ontoTuple (Right []) vars of
Left str -> Left str
Right lst -> Right $ reverse lst
where
ontoTuple (Left str) _ = Left str
ontoTuple (Right lst) (l,r) =
case convFromPHPImplicitOM l of
Left errl -> Left errl
Right l'' ->
case conv r of
Left errr -> Left errr
Right r'' ->
Right ((l'',r'') : lst)
instance ConversionFromPHPImplicitValueOrMismatch Bool where
convFromPHPImplicitOM var =
Right $ boolFromPHPLooseComparisonWithTrue var
instance ConversionFromPHPImplicitValueOrMismatch Double where
convFromPHPImplicitOM (PHPSessionValueFloat (Right var)) = (Right) var
convFromPHPImplicitOM (PHPSessionValueFloat (Left var)) = (Right . fromIntegral) var
convFromPHPImplicitOM (PHPSessionValueString str) =
case reads str' of
[(val,"")] -> Right val
[] -> let v = PHPSessionValueString str
in mismatchError v "Double"
where
str' = LBS.unpack str
convFromPHPImplicitOM var =
let intvar = convFromPHPImplicitOM var :: Either String Int
in case intvar of
Left message -> Left message
Right intvar' ->
(Right . fromIntegral) intvar'
instance ConversionFromPHPImplicitValueOrMismatch Int where
convFromPHPImplicitOM (PHPSessionValueBool b) = Right $ if b then 1 else 0
convFromPHPImplicitOM (PHPSessionValueFloat lr) =
Right $ case lr of
Left i -> i
Right f -> floor f
convFromPHPImplicitOM (PHPSessionValueInt val) = Right $ fromIntegral val
convFromPHPImplicitOM (PHPSessionValueString str) =
case reads str' of
[(val,"")] -> Right $ fromIntegral val
[] ->
case reads str' of
[(valdbl,"")] -> Right $ floor valdbl
[] -> let v = PHPSessionValueString str
in mismatchError v "Int"
where str' = LBS.unpack str
convFromPHPImplicitOM v = mismatchError v "Int"
instance ConversionFromPHPImplicitValueOrMismatch Int32 where
convFromPHPImplicitOM var =
let var' = convFromPHPImplicitOM var :: Either String Int
in case var' of
Left message -> Left message
Right int -> Right $ fromIntegral int
instance ConversionFromPHPImplicitValueOrMismatch Int64 where
convFromPHPImplicitOM var =
let var' = convFromPHPImplicitOM var :: Either String Int
in case var' of
Left message -> Left message
Right int -> Right $ fromIntegral int
instance ConversionFromPHPImplicitValueOrMismatch (PHPSessionClassName, [(PHPSessionValue,PHPSessionValue)]) where
convFromPHPImplicitOM (PHPSessionValueArray arr) = Right (phpStdClass,arr)
convFromPHPImplicitOM (PHPSessionValueBool b) = Right (phpStdClass,[(phpScalarMember, PHPSessionValueBool b)])
convFromPHPImplicitOM (PHPSessionValueFloat a) = Right (phpStdClass,[(phpScalarMember, PHPSessionValueFloat a)])
convFromPHPImplicitOM (PHPSessionValueInt i) = Right (phpStdClass,[(phpScalarMember, PHPSessionValueInt i)])
convFromPHPImplicitOM (PHPSessionValueNull) = Right (phpStdClass,[])
convFromPHPImplicitOM (PHPSessionValueObject cls arr) = Right (cls,arr)
convFromPHPImplicitOM (PHPSessionValueString a) = Right (phpStdClass,[(phpScalarMember, PHPSessionValueString a)])
convFromPHPImplicitOM v = mismatchError v "(PHPSessionClassName, [(PHPSessionValue,PHPSessionValue)])"
phpStdClass = PHPSessionClassName "stdClass"
phpScalarMember = PHPSessionValueString "scalar"
instance ConversionFromPHPImplicitValueOrMismatch (PHPSessionClassName, LBS.ByteString) where
convFromPHPImplicitOM (PHPSessionValueObjectSerializeable cls arr) = Right (cls,arr)
convFromPHPImplicitOM v = mismatchError v "(PHPSessionClassName, LBS.ByteString)"
instance ConversionFromPHPImplicitValueOrMismatch LBS.ByteString where
convFromPHPImplicitOM (PHPSessionValueBool b) =
case b of
True -> Right "1"
False -> Right ""
convFromPHPImplicitOM (PHPSessionValueFloat a) =
case a of
Left i -> (Right . LBS.pack . show) i
Right f -> (Right . LBS.pack . show) f
convFromPHPImplicitOM (PHPSessionValueInt i) =
(Right . LBS.pack . show) i
convFromPHPImplicitOM (PHPSessionValueString var) = Right var
convFromPHPImplicitOM v = mismatchError v "ByteString"
instance ConversionFromPHPImplicitValueOrMismatch BS.ByteString where
convFromPHPImplicitOM var =
let var' = convFromPHPImplicitOM var :: Either String LBS.ByteString
in case var' of
Left message -> Left message
Right str -> Right (BS.concat $ LBS.toChunks str)
instance ConversionFromPHPImplicitValueOrMismatch a => ConversionFromPHPImplicitValueOrMismatch (Maybe a) where
convFromPHPImplicitOM PHPSessionValueNull = Right Nothing
convFromPHPImplicitOM v =
case convFromPHPImplicitOM v of
Left s -> Left s
Right b' -> Right (Just b')
mismatchError v totype =
Left $ "Type mismatch converting from (" ++ show v ++ ") to " ++ totype
convFromPHPImplicit :: ConversionFromPHPImplicitValueOrMismatch b => PHPSessionValue -> b
convFromPHPImplicit var =
case convFromPHPImplicitOM var of
Left message -> error message
Right var' -> var'
convFromPHPImplicitSafe
:: ConversionFromPHPImplicitValueOrMismatch b =>
PHPSessionValue -> Either String b
convFromPHPImplicitSafe var = convFromPHPImplicitOM var