module System.Console.CmdArgs.Implicit.Read(isReadBool, toReadContainer, reader, addContainer, readHelp) where
import Data.Generics.Any
import qualified Data.Generics.Any.Prelude as A
import System.Console.CmdArgs.Explicit
import Data.Char
import Data.Either
import Data.List
data ReadContainer
= ReadList ReadAtom
| ReadMaybe ReadAtom
| ReadAtom ReadAtom
data ReadAtom
= ReadBool
| ReadInt
| ReadInteger
| ReadFloat
| ReadDouble
| ReadString
| ReadEnum [(String,Any)]
| ReadTuple [ReadAtom]
isReadBool x = case fromReadContainer x of
ReadBool{} -> True
_ -> False
fromReadContainer :: ReadContainer -> ReadAtom
fromReadContainer (ReadList x) = x
fromReadContainer (ReadMaybe x) = x
fromReadContainer (ReadAtom x) = x
toReadContainer :: Any -> Maybe ReadContainer
toReadContainer x = case typeShell x of
"[]" | typeName x /= "[Char]" -> fmap ReadList $ toReadAtom $ A.fromList x
"Maybe" -> fmap ReadMaybe $ toReadAtom $ A.fromMaybe x
_ -> fmap ReadAtom $ toReadAtom x
toReadAtom :: Any -> Maybe ReadAtom
toReadAtom x = case typeName x of
"Bool" -> Just ReadBool
"Int" -> Just ReadInt
"Integer" -> Just ReadInteger
"Float" -> Just ReadFloat
"Double" -> Just ReadDouble
"[Char]" -> Just ReadString
_ | A.isTuple x -> fmap ReadTuple $ mapM toReadAtom $ children $ compose0 x $ typeShell x
_ -> toReadEnum x
toReadEnum :: Any -> Maybe ReadAtom
toReadEnum x
| isAlgType x && all ((==) 0 . arity . compose0 x) cs
= Just $ ReadEnum [(map toLower c, compose0 x c) | c <- cs]
| otherwise = Nothing
where cs = ctors x
reader :: ReadContainer -> String -> Any -> Either String Any
reader t s x = fmap (addContainer t x) $ readAtom (fromReadContainer t) s
addContainer :: ReadContainer -> Any -> Any -> Any
addContainer (ReadAtom _) _ x = x
addContainer (ReadMaybe _) o x = A.just_ o x
addContainer (ReadList _) o x = A.append o $ A.cons x $ A.nil_ o
readAtom :: ReadAtom -> String -> Either String Any
readAtom ty s = case ty of
ReadBool -> maybe (Left $ "Could not read as boolean, " ++ show s) (Right . Any) $ parseBool s
ReadInt -> f (0::Int)
ReadInteger -> f (0::Integer)
ReadFloat -> f (0::Float)
ReadDouble -> f (0::Double)
ReadString -> Right $ Any s
ReadEnum xs -> readEnum (map toLower s) xs
ReadTuple _ -> readTuple ty s
where
f t = case reads s of
[(x,"")] -> Right $ Any $ x `asTypeOf` t
_ -> Left $ "Could not read as type " ++ show (typeOf $ Any t) ++ ", " ++ show s
readEnum:: String -> [(String,a)] -> Either String a
readEnum a xs | null ys = Left $ "Could not read, expected one of: " ++ unwords (map fst xs)
| length ys > 1 = Left $ "Ambiguous read, could be any of: " ++ unwords (map fst ys)
| otherwise = Right $ snd $ head ys
where ys = filter (\x -> a `isPrefixOf` fst x) xs
readTuple :: ReadAtom -> String -> Either String Any
readTuple ty s
| length ss /= length ts = Left "Incorrect number of comma separated fields for tuple"
| not $ null left = Left $ head left
| otherwise = Right $ gen right
where
(left,right) = partitionEithers $ zipWith readAtom ts ss
(ts,gen) = flatten ty
ss = split s
split :: String -> [String]
split = lines . map (\x -> if x == ',' then '\n' else x)
flatten :: ReadAtom -> ([ReadAtom], [Any] -> Any)
flatten (ReadTuple xs) = (concat ns, A.tuple . zipWith ($) fs . unconcat ns)
where (ns,fs) = unzip $ map flatten xs
flatten x = ([x], \[a] -> a)
unconcat :: [[w]] -> [a] -> [[a]]
unconcat [] [] = []
unconcat (w:ws) xs = x1 : unconcat ws x2
where (x1,x2) = splitAt (length w) xs
readHelp :: ReadContainer -> String
readHelp = f . fromReadContainer
where
f ReadBool = "BOOL"
f ReadInt = "INT"
f ReadInteger = "INT"
f ReadFloat = "NUM"
f ReadDouble = "NUM"
f ReadString = "ITEM"
f (ReadEnum xs) = map toUpper $ typeShell $ snd $ head xs
f (ReadTuple xs) = intercalate "," $ map f xs