1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
|
{-# LANGUAGE PatternGuards #-}
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.Int
import Data.Word
import Data.List
import Data.Maybe
data Reader = Reader
{readerHelp :: String
,readerBool :: Bool
,readerParts :: Int
,readerFixup :: Any -> Any -- If a list, then 'reverse', otherwise nothing, so we can build up using cons in O(n)
,readerRead :: Any -> String -> Either String Any
}
-- reader has an actual value of type Any that can be inspected
-- reader_ has a value of type _|_ instead
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.cons` o) $ readerRead_ r s, readerFixup = A.reverse}
reader x | isAlgType x, [ctor] <- ctors x, [child] <- children x = do
-- newtype wrapper, just forward it
r <- reader child
let down = head . children
let up o c = recompose o [c]
return r{readerFixup = \x -> up x $ readerFixup r $ down x
,readerRead = \x -> either Left (Right . up x) . readerRead r (down x)
}
reader x = reader_ x
reader_ :: Any -> Maybe Reader
reader_ x | A.isString x = Just $ Reader "ITEM" False 1 id $ const $ Right . Any
reader_ x | typeName x == "Bool" = Just $ Reader "BOOL" True 1 id $ const $ \s ->
maybe (Left $ "Could not read as boolean, " ++ show s) (Right . Any) $ parseBool s
reader_ x | res:_ <- catMaybes
[f "INT" (0::Integer), f "NUM" (0::Float), f "NUM" (0::Double)
,f "INT" (0::Int), f "INT" (0::Int8), f "INT" (0::Int16), f "INT" (0::Int32), f "INT" (0::Int64)
,f "NAT" (0::Word), f "NAT" (0::Word8), f "NAT" (0::Word16), f "NAT" (0::Word32), f "NAT" (0::Word64)
] = Just res
where
ty = typeOf x
f hlp t | typeOf (Any t) /= ty = Nothing
| otherwise = Just $ Reader hlp False 1 id $ 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 id $ 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 | isAlgType 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 id $ 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)
|
