module System.Console.CmdArgs.Implicit.Reader(Reader(..), reader) where
import Data.Generics.Any
import qualified Data.Generics.Any.Prelude as A
import System.Console.CmdArgs.Explicit
import Data.Char
import Data.List
data Reader = Reader
{readerHelp :: String
,readerBool :: Bool
,readerParts :: Int
,readerRead :: Any -> String -> Either String Any
}
readerRead_ r = readerRead r $ error "Invariant broken: reader/reader_"
reader :: Any -> Maybe Reader
reader x | A.isList x && not (A.isString x) = do
r <- reader_ $ A.fromList x
return r{readerRead = \o s -> fmap (A.append o . A.list_ x) $ readerRead_ r s}
reader x = reader_ x
reader_ :: Any -> Maybe Reader
reader_ x | A.isString x = Just $ Reader "ITEM" False 1 $ const $ Right . Any
reader_ x | typeName x == "Bool" = Just $ Reader "BOOL" True 1 $ const $ \s ->
maybe (Left $ "Could not read as boolean, " ++ show s) (Right . Any) $ parseBool s
reader_ x
| ty == "Int" = f "INT" (0::Int)
| ty == "Integer" = f "INT" (0::Integer)
| ty == "Float" = f "NUM" (0::Float)
| ty == "Double" = f "NUM" (0::Double)
where
ty = typeName x
f hlp t = Just $ Reader hlp False 1 $ const $ \s -> case reads s of
[(x,"")] -> Right $ Any $ x `asTypeOf` t
_ -> Left $ "Could not read as type " ++ show (typeOf $ Any t) ++ ", " ++ show s
reader_ x | A.isList x = do
r <- reader_ $ A.fromList x
return $ r{readerRead = const $ fmap (A.list_ x) . readerRead_ r}
reader_ x | A.isMaybe x = do
r <- reader_ $ A.fromMaybe x
return $ r{readerRead = const $ fmap (A.just_ x) . readerRead_ r}
reader_ x | isAlgType x && length xs > 1 && all ((==) 0 . arity . snd) xs
= Just $ Reader (map toUpper $ typeShell x) (typeName x == "Bool") 1 $ const $ rd . map toLower
where
xs = [(map toLower c, compose0 x c) | c <- ctors x]
rd s | null ys = Left $ "Could not read, expected one of: " ++ unwords (map fst xs)
| Just (_,x) <- find ((==) s . fst) ys = Right x
| length ys > 1 = Left $ "Ambiguous read, could be any of: " ++ unwords (map fst ys)
| otherwise = Right $ snd $ head ys
where ys = filter (isPrefixOf s . fst) xs
reader_ x | [c] <- ctors x, x <- compose0 x c = do
let cs = children x
rs <- mapM reader_ cs
let n = sum $ map readerParts rs
return $ Reader (uncommas $ map readerHelp rs) (map readerBool rs == [True]) n $ const $ \s ->
let ss = commas s in
if n == 1 then fmap (recompose x . return) $ readerRead_ (head $ filter ((==) 1 . readerParts) rs) s
else if length ss /= n then Left "Incorrect number of commas for fields"
else fmap (recompose x) $ sequenceEither $ zipWith readerRead_ rs $ map uncommas $ takes (map readerParts rs) ss
reader_ _ = Nothing
uncommas = intercalate ","
commas = lines . map (\x -> if x == ',' then '\n' else x)
takes [] _ = []
takes (i:is) xs = a : takes is b
where (a,b) = splitAt i xs
sequenceEither = foldr f (Right [])
where f (Left x) _ = Left x
f _ (Left x) = Left x
f (Right x) (Right xs) = Right (x:xs)