add an env variable source

1 files changed, 24 insertions, 17 deletions

diff --git a/src/Conftrack/Value.hs b/src/Conftrack/Value.hs
index 6fe8780..fef8f87 100644
--- a/src/Conftrack/Value.hs
+++ b/src/Conftrack/Value.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Conftrack.Value (key, Value(..), ConfigError(..), Key(..), ConfigValue(..), Origin(..), KeyPart, prefixedWith) where
 
@@ -22,6 +23,7 @@ import Language.Haskell.TH.Syntax (Lift(lift))
 data Value =
   ConfigString BS.ByteString
   | ConfigInteger Integer
+  | ConfigMaybeInteger BS.ByteString Integer
   | ConfigOther Text Text
   | ConfigBool Bool
   | ConfigNull
@@ -43,9 +45,6 @@ key = QuasiQuoter
   , quoteType = \_ -> fail "key quasi-quote cannot be used for types"
   , quoteDec = \_ -> fail "key quasi-quote cannot be used in declarations"}
 
-blub :: String -> Key
-blub = undefined
-
 
 prefixedWith :: Key -> [KeyPart] -> Key
 prefixedWith (Key key) prefix = Key (prependList prefix key)
@@ -63,17 +62,24 @@ class ConfigValue a where
 data Origin = Origin Key Text
   deriving Show
 
+withString :: (BS.ByteString -> Either ConfigError a) -> Value -> Either ConfigError a
+withString f (ConfigString a) = f a
+withString f (ConfigMaybeInteger a _) = f a
+withString _ val = Left (TypeMismatch "text" val)
+
+withInteger :: (Integer -> Either ConfigError a) -> Value -> Either ConfigError a
+withInteger f (ConfigInteger a) = f a
+withInteger f (ConfigMaybeInteger _ a) = f a
+withInteger _ val = Left (TypeMismatch "integer" val)
+
 instance ConfigValue Text where
-  fromConfig (ConfigString a) = Right (BS.decodeUtf8 a)
-  fromConfig val = Left (TypeMismatch "text" val)
+  fromConfig = withString (Right . BS.decodeUtf8)
 
 instance ConfigValue Integer where
-  fromConfig (ConfigInteger a) = Right a
-  fromConfig val = Left (TypeMismatch "integer" val)
+  fromConfig = withInteger Right
 
 instance ConfigValue Int where
-  fromConfig (ConfigInteger a) = Right (fromInteger a)
-  fromConfig val = Left (TypeMismatch "integer" val)
+  fromConfig = withInteger (Right . fromInteger)
 
 instance ConfigValue Bool where
   fromConfig (ConfigBool b) = Right b
@@ -84,15 +90,16 @@ instance ConfigValue a => ConfigValue (Maybe a) where
   fromConfig just = fmap Just (fromConfig just)
 
 instance ConfigValue OsPath where
-  fromConfig (ConfigString text) = case encodeUtf (T.unpack (BS.decodeUtf8 text)) of
-    Right path -> Right path
-    Left err -> Left (ParseError (T.pack $ show err))
-  fromConfig val = Left (TypeMismatch "path" val)
+  fromConfig = \case
+    (ConfigString text) -> stringToPath text
+    (ConfigMaybeInteger text _) -> stringToPath text
+    val -> Left (TypeMismatch "path" val)
+   where stringToPath text = case encodeUtf (T.unpack (BS.decodeUtf8 text)) of
+          Right path -> Right path
+          Left err -> Left (ParseError (T.pack $ show err))
 
 instance ConfigValue LB.ByteString where
-  fromConfig (ConfigString strict) = Right (LB.fromStrict strict)
-  fromConfig val = Left (TypeMismatch "string" val)
+  fromConfig = withString (Right . LB.fromStrict)
 
 instance ConfigValue BS.ByteString where
-  fromConfig (ConfigString string) = Right string
-  fromConfig val = Left (TypeMismatch "string" val)
+  fromConfig = withString Right