aws-sdk-text-converter 0.2.0.0 → 0.3
raw patch · 8 files changed
+195/−153 lines, 8 files
Files
- Cloud/AWS/Lib/FromText.hs +2/−101
- Cloud/AWS/Lib/FromText/Class.hs +83/−0
- Cloud/AWS/Lib/FromText/TH.hs +26/−0
- Cloud/AWS/Lib/ToText.hs +4/−46
- Cloud/AWS/Lib/ToText/Class.hs +52/−0
- Cloud/AWS/Lib/ToText/TH.hs +21/−0
- aws-sdk-text-converter.cabal +5/−1
- test/Spec.hs +2/−5
Cloud/AWS/Lib/FromText.hs view
@@ -7,106 +7,7 @@ ) , deriveFromText , failText- -- Re-exports- , IPv4- , AddrRange- , Text- , UTCTime ) where -import Control.Applicative ((<$>))-import Control.Monad-import Data.IP (IPv4, AddrRange)-import Data.Monoid ((<>))-import Data.Text (Text)-import qualified Data.Text as T-import Data.Time (UTCTime)-import qualified Data.Time as Time-import qualified Data.Time.Parse as TP-import Language.Haskell.TH-import Safe--class FromText a where- fromText :: Monad m => Text -> m a-- fromText' :: Monad m => Text -> m a- fromText' name- = maybe (failText name) return- . fromText- $ name-- fromNamedText :: Monad m => Text -> Maybe Text -> m a- fromNamedText name- = maybe- (failText $ T.pack "no text name=" <> name)- fromText'--failText :: Monad m => Text -> m a-failText msg = fail $ "FromText error: " <> T.unpack msg--instance FromText a => FromText (Maybe a) where- fromText' = return . join . fromText- fromNamedText _name Nothing = return Nothing- fromNamedText _name (Just t) = return $ fromText t- fromText = return . fromText--instance FromText Int where- fromText = fromTextToRead--instance FromText Integer where- fromText = fromTextToRead--instance FromText Double where- fromText = fromTextToRead--instance FromText IPv4 where- fromText = fromTextToRead--instance FromText (AddrRange IPv4) where- fromText = fromTextToRead--fromTextToRead :: (Monad m, Read a) => Text -> m a-fromTextToRead = readM . T.unpack--readM :: (Monad m, Read a) => String -> m a-readM a = maybe (fail $ "read failue: " <> a) return $ readMay a--instance FromText Text where- fromText t- | t == "" = failText "Text"- | otherwise = return t--instance FromText Bool where- fromText "true" = return True- fromText "false" = return False- fromText _ = failText "Bool"--instance FromText UTCTime where- fromText t- = maybe- (fail "UTCTime")- (return . Time.localTimeToUTC Time.utc)- $ fst <$> (TP.strptime fmt $ T.unpack t)- where- fmt = "%FT%T"--instance FromText () where- fromText _ = return ()- fromNamedText _ = maybe (return ()) fromText--deriveFromText :: String -> [String] -> DecsQ-deriveFromText dstr strs = do- ctrs <- map (\(NormalC name _) -> name) <$> cons- x <- newName "x"- let cases = caseE (varE x) (map f (zip strs ctrs) ++ [wild])- let fun = funD 'fromText [clause [varP x] (normalB cases) []]- (:[]) <$> instanceD ctx typ [fun]- where- d = mkName dstr- cons = do- (TyConI (DataD _ _ _ cs _)) <- reify d- return cs- f (s, t) = match (litP $ stringL s) (normalB $ [|return $(conE t)|]) []- wild = match wildP (normalB [|fail dstr|]) []- typ = appT (conT ''FromText) (conT d)- ctx = return []+import Cloud.AWS.Lib.FromText.Class (FromText(..), failText)+import Cloud.AWS.Lib.FromText.TH (deriveFromText)
+ Cloud/AWS/Lib/FromText/Class.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE FlexibleInstances #-}++module Cloud.AWS.Lib.FromText.Class+ where++import Control.Applicative ((<$>))+import Control.Monad+import Data.IP (IPv4, AddrRange)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time (UTCTime)+import qualified Data.Time as Time+import qualified Data.Time.Parse as TP+import Safe++class FromText a where+ fromText :: Monad m => Text -> m a++ fromText' :: Monad m => Text -> m a+ fromText' name+ = maybe (failText name) return+ . fromText+ $ name++ fromNamedText :: Monad m => Text -> Maybe Text -> m a+ fromNamedText name+ = maybe+ (failText $ T.pack "no text name=" <> name)+ fromText'++failText :: Monad m => Text -> m a+failText msg = fail $ "FromText error: " <> T.unpack msg++instance FromText a => FromText (Maybe a) where+ fromText' = return . join . fromText+ fromNamedText _name Nothing = return Nothing+ fromNamedText _name (Just t) = return $ fromText t+ fromText = return . fromText++instance FromText Int where+ fromText = fromTextToRead++instance FromText Integer where+ fromText = fromTextToRead++instance FromText Double where+ fromText = fromTextToRead++instance FromText IPv4 where+ fromText = fromTextToRead++instance FromText (AddrRange IPv4) where+ fromText = fromTextToRead++fromTextToRead :: (Monad m, Read a) => Text -> m a+fromTextToRead = readM . T.unpack++readM :: (Monad m, Read a) => String -> m a+readM a = maybe (fail $ "read failue: " <> a) return $ readMay a++instance FromText Text where+ fromText t+ | t == "" = failText "Text"+ | otherwise = return t++instance FromText Bool where+ fromText "true" = return True+ fromText "false" = return False+ fromText _ = failText "Bool"++instance FromText UTCTime where+ fromText t+ = maybe+ (fail "UTCTime")+ (return . Time.localTimeToUTC Time.utc)+ $ fst <$> (TP.strptime fmt $ T.unpack t)+ where+ fmt = "%FT%T"++instance FromText () where+ fromText _ = return ()+ fromNamedText _ = maybe (return ()) fromText
+ Cloud/AWS/Lib/FromText/TH.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE TemplateHaskell #-}++module Cloud.AWS.Lib.FromText.TH+ where++import Control.Applicative ((<$>))+import Language.Haskell.TH++import Cloud.AWS.Lib.FromText.Class (FromText(..))++deriveFromText :: String -> [String] -> DecsQ+deriveFromText dstr strs = do+ ctrs <- map (\(NormalC name _) -> name) <$> cons+ x <- newName "x"+ let cases = caseE (varE x) (map f (zip strs ctrs) ++ [wild])+ let fun = funD 'fromText [clause [varP x] (normalB cases) []]+ (:[]) <$> instanceD ctx typ [fun]+ where+ d = mkName dstr+ cons = do+ (TyConI (DataD _ _ _ cs _)) <- reify d+ return cs+ f (s, t) = match (litP $ stringL s) (normalB $ [|return $(conE t)|]) []+ wild = match wildP (normalB [|fail dstr|]) []+ typ = appT (conT ''FromText) (conT d)+ ctx = return []
Cloud/AWS/Lib/ToText.hs view
@@ -1,52 +1,10 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-} module Cloud.AWS.Lib.ToText ( ToText (toText)+ , deriveToText ) where -import Data.ByteString (ByteString)-import Data.IP (IPv4, AddrRange)-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Time (UTCTime)-import qualified Data.Time as Time-import System.Locale (defaultTimeLocale)--class ToText a where- toText :: a -> Text- toMaybeText :: a -> Maybe Text- toMaybeText = Just . toText--instance ToText Text where- toText t = t--instance ToText ByteString where- toText = T.decodeUtf8--instance ToText Bool where- toText True = "true"- toText False = "false"--instance ToText UTCTime where- toText- = T.pack- . Time.formatTime defaultTimeLocale "%FT%T"--instance ToText Int where- toText = toTextFromShow--instance ToText Integer where- toText = toTextFromShow--instance ToText Double where- toText = toTextFromShow--instance ToText IPv4 where- toText = toTextFromShow--instance ToText (AddrRange IPv4) where- toText = toTextFromShow--toTextFromShow :: Show a => a -> Text-toTextFromShow = T.pack . show+import Cloud.AWS.Lib.ToText.Class (ToText(toText))+import Cloud.AWS.Lib.ToText.TH (deriveToText)
+ Cloud/AWS/Lib/ToText/Class.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE FlexibleInstances #-}++module Cloud.AWS.Lib.ToText.Class+ ( ToText (toText)+ ) where++import Data.ByteString (ByteString)+import Data.IP (IPv4, AddrRange)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Time (UTCTime)+import qualified Data.Time as Time+import System.Locale (defaultTimeLocale)++class ToText a where+ toText :: a -> Text+ toMaybeText :: a -> Maybe Text+ toMaybeText = Just . toText++instance ToText Text where+ toText t = t++instance ToText ByteString where+ toText = T.decodeUtf8++instance ToText Bool where+ toText True = "true"+ toText False = "false"++instance ToText UTCTime where+ toText+ = T.pack+ . Time.formatTime defaultTimeLocale "%FT%T"++instance ToText Int where+ toText = toTextFromShow++instance ToText Integer where+ toText = toTextFromShow++instance ToText Double where+ toText = toTextFromShow++instance ToText IPv4 where+ toText = toTextFromShow++instance ToText (AddrRange IPv4) where+ toText = toTextFromShow++toTextFromShow :: Show a => a -> Text+toTextFromShow = T.pack . show
+ Cloud/AWS/Lib/ToText/TH.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE TemplateHaskell #-}++module Cloud.AWS.Lib.ToText.TH+ ( deriveToText+ ) where++import Control.Applicative+import Language.Haskell.TH++import Cloud.AWS.Lib.ToText.Class (ToText(..))++deriveToText :: String -> [String] -> DecsQ+deriveToText name value = do+ let dname = mkName name+ (TyConI (DataD _ _ _ cs _)) <- reify dname+ let clauses = map+ (\(npq, str) -> clause [npq] (normalB $ stringE str) [])+ (zip (map (\(NormalC n _) -> conP n []) cs) value)+ let fun = funD 'toText clauses+ let typ = appT (conT ''ToText) (conT dname)+ (:[]) <$> instanceD (return []) typ [fun]
aws-sdk-text-converter.cabal view
@@ -1,5 +1,5 @@ name: aws-sdk-text-converter-version: 0.2.0.0+version: 0.3 synopsis: The text converter for aws-sdk. description: The text converter for aws-sdk. license: BSD3@@ -14,6 +14,10 @@ library exposed-modules: Cloud.AWS.Lib.FromText , Cloud.AWS.Lib.ToText+ other-modules: Cloud.AWS.Lib.FromText.Class+ , Cloud.AWS.Lib.FromText.TH+ , Cloud.AWS.Lib.ToText.Class+ , Cloud.AWS.Lib.ToText.TH ghc-options: -Wall -fno-warn-unused-do-bind default-extensions: OverloadedStrings build-depends: base == 4.*
test/Spec.hs view
@@ -45,10 +45,7 @@ data A = B | C deriving (Eq, Show) -instance ToText A where- toText B = "ab"- toText C = "ac"-+deriveToText "A" ["ab", "ac"] deriveFromText "A" ["ab", "ac"] instance Arbitrary A where@@ -66,6 +63,6 @@ prop "AddrRange IPv4" (prop_class :: AddrRange IPv4 -> Bool) prop "Maybe Int" (prop_mclass :: Int -> Bool) it "convert Nothing" testNothing- prop "deriveFromText" (prop_class :: A -> Bool)+ prop "deriveFromText/deriveToText" (prop_class :: A -> Bool) prop "Unit" (\t -> fromText t == Just ()) it "convert Nothing to Unit" testConvertNothingToUnit