module Data.PropertyList.PropertyListItem
(PropertyListItem(..)) where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Fold
import Data.PropertyList.Algebra
import Data.PropertyList.Types
import qualified Data.Map as M
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as Lazy (ByteString)
import Data.ByteString.Class
import Data.Time
import Data.Char
import Data.Int
import Data.Word
import Text.XML.HaXml.OneOfN
import Control.Monad
import Control.Monad.Identity
import qualified Data.Traversable as Traversable
import Data.Generics
tryRead :: Read a => String -> Maybe a
tryRead s = case reads s of
[(d, "")] -> Just d
_ -> Nothing
tryToIntegral :: (RealFrac a, Integral b) => a -> Maybe b
tryToIntegral d = case properFraction d of
(i, 0) -> Just i
_ -> Nothing
class PropertyListItem i where
toPropertyList :: i -> PropertyList
fromPropertyList :: PropertyList -> Maybe i
listToPropertyList :: [i] -> PropertyList
listToPropertyList = plArray . map toPropertyList
listFromPropertyList :: PropertyList -> Maybe [i]
listFromPropertyList (fromPlArray -> Just x) = mapM fromPropertyList x
listFromPropertyList _ = Nothing
instance PropertyListItem a => PropertyListItem [a] where
toPropertyList = listToPropertyList
fromPropertyList = listFromPropertyList
instance PropertyListItem PropertyList where
toPropertyList = id
fromPropertyList = Just
instance PropertyListItem ByteString where
toPropertyList = plData
fromPropertyList (fromPlData -> Just x) = Just x
fromPropertyList (fromPlString -> Just x) = Just (toStrictByteString x)
fromPropertyList _ = Nothing
instance PropertyListItem Lazy.ByteString where
toPropertyList = plData . toStrictByteString
fromPropertyList (fromPlData -> Just x) = Just (toLazyByteString x)
fromPropertyList (fromPlString -> Just x) = Just (toLazyByteString x)
fromPropertyList _ = Nothing
instance PropertyListItem UTCTime where
toPropertyList = plDate
fromPropertyList (fromPlDate -> Just x) = Just x
fromPropertyList _ = Nothing
instance PropertyListItem a => PropertyListItem (M.Map String a) where
toPropertyList = plDict . fmap toPropertyList
fromPropertyList (fromPlDict -> Just x) = Traversable.mapM fromPropertyList x
fromPropertyList _ = Nothing
instance PropertyListItem Double where
toPropertyList = plReal
fromPropertyList (fromPlInt -> Just i) = Just (fromInteger i)
fromPropertyList (fromPlReal -> Just d) = Just d
fromPropertyList (fromPlString -> Just s) = tryRead s
fromPropertyList _ = Nothing
instance PropertyListItem Float where
toPropertyList = toPropertyList . (realToFrac :: Float -> Double)
fromPropertyList = fmap (realToFrac :: Double -> Float) . fromPropertyList
$( do
decls <- [d|
instance PropertyListItem Integer where
toPropertyList = plInt . fromIntegral
fromPropertyList pl = case runIdentity (plistCoalgebra pl) of
PLInt i -> Just (fromIntegral i)
PLReal d -> tryToIntegral d
PLString s -> tryRead s
_ -> Nothing
|]
sequence
[ everywhereM (mkM (return . replace)) dec
| t <- [''Integer, ''Int,
''Int8, ''Int16, ''Int32, ''Int64,
''Word8, ''Word16, ''Word32, ''Word64]
, dec <- decls
, let replace name
| name == ''Integer = t
| otherwise = name
]
)
instance PropertyListItem Char where
toPropertyList c = plString [c]
fromPropertyList (fromPlString -> Just [c]) = Just c
fromPropertyList _ = Nothing
listToPropertyList = plString
listFromPropertyList (fromPlString -> Just x) = Just x
listFromPropertyList (fromPlData -> Just x) = Just (fromStrictByteString x)
listFromPropertyList (fromPlBool -> Just True) = Just "YES"
listFromPropertyList (fromPlBool -> Just False) = Just "NO"
listFromPropertyList (fromPlInt -> Just i) = Just (show i)
listFromPropertyList (fromPlReal -> Just d) = Just (show d)
listFromPropertyList other = Nothing
instance PropertyListItem Bool where
toPropertyList = plBool
fromPropertyList (fromPlBool -> Just d) = Just d
fromPropertyList (fromPlString -> Just b)
| map toLower b `elem` ["yes", "true"]
= Just True
| map toLower b `elem` ["no", "false"]
= Just False
fromPropertyList _ = Nothing
$( let types = ''Either : [mkTcName ("OneOf" ++ show n) | n <- [2..20]]
mkTcName n = Name (mkOccName n) nameFlavour
where Name _ nameFlavour = ''OneOf2
mkInstance typeName = do
TyConI (DataD _ _ _ cons _) <- reify typeName
let conNames = [name | NormalC name _ <- cons]
let tyVarNames = zipWith (\con n -> mkName ("a" ++ show n)) conNames [1..]
tyVars = map varT tyVarNames
typeWithVars = foldl appT (conT typeName) tyVars
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612
preds = [classP ''PropertyListItem [tyVar] | tyVar <- tyVars]
context = cxt preds
#else
context = mapM (appT (conT ''PropertyListItem)) tyVars
#endif
inst = appT (conT ''PropertyListItem) typeWithVars
pl = mkName "pl"
whre =
[ funD 'toPropertyList [clause [] (normalB toPLbody ) []]
, funD 'fromPropertyList [clause [varP pl] (normalB fromPLbody) []]
]
toPLbody = appsE (fold typeName : map (const (varE 'toPropertyList)) conNames)
fromPLbody = appE (varE 'msum) $ listE
[ [| fmap $(conE con) (fromPropertyList $(varE pl)) |]
| con <- conNames
]
instanceD context inst whre
in
mapM mkInstance types
)