Clean up interface to mutable vectors
[darcs-mirrors/vector.git] / internal / GenUnboxTuple.hs
1 {-# LANGUAGE ParallelListComp #-}
2 module Main where
3
4 import Text.PrettyPrint
5
6 import System.Environment ( getArgs )
7
8 main = do
9 [s] <- getArgs
10 let n = read s
11 mapM_ (putStrLn . render . generate) [2..n]
12
13 generate :: Int -> Doc
14 generate n =
15 vcat [ data_instance "MVector s" "MV"
16 , data_instance "Vector" "V"
17 , class_instance "Unbox"
18 , class_instance "M.MVector MVector" <+> text "where"
19 , nest 2 $ vcat $ map method methods_MVector
20 , class_instance "G.Vector Vector" <+> text "where"
21 , nest 2 $ vcat $ map method methods_Vector
22 ]
23
24 where
25 vars = map char $ take n ['a'..]
26 varss = map (<> char 's') vars
27 tuple f = parens $ hsep $ punctuate comma $ map f vars
28 vtuple f = parens $ sep $ punctuate comma $ map f vars
29 con s = text s <> char '_' <> int n
30 var c = text (c : "_")
31
32 data_instance ty c
33 = hang (hsep [text "data instance", text ty, tuple id])
34 4
35 (hsep [char '=', con c, text "{-# UNPACK #-} !Int"
36 , vcat $ map (\v -> parens (text ty <+> v)) vars])
37
38 class_instance cls
39 = text "instance" <+> vtuple (text "Unbox" <+>)
40 <+> text "=>" <+> text cls <+> tuple id
41
42
43 pat c = parens $ con c <+> var 'n' <+> sep varss
44 patn c n = parens $ con c <+> (var 'n' <> int n)
45 <+> sep [v <> int n | v <- varss]
46
47 qM s = text "M." <> text s
48 qG s = text "G." <> text s
49
50 gen_length c _ = (pat c, var 'n')
51
52 gen_unsafeSlice mod c rec
53 = (pat c <+> var 'i' <+> var 'm',
54 con c <+> var 'm'
55 <+> vcat [parens
56 $ text mod <> char '.' <> text rec
57 <+> vs <+> var 'i' <+> var 'm'
58 | vs <- varss])
59
60
61 gen_overlaps rec = (patn "MV" 1 <+> patn "MV" 2,
62 vcat $ r : [text "||" <+> r | r <- rs])
63 where
64 r : rs = [qM rec <+> v <> char '1' <+> v <> char '2' | v <- varss]
65
66 gen_unsafeNew rec
67 = (var 'n',
68 mk_do [v <+> text "<-" <+> qM rec <+> var 'n' | v <- varss]
69 $ text "return $" <+> con "MV" <+> var 'n' <+> sep varss)
70
71 gen_unsafeNewWith rec
72 = (var 'n' <+> tuple id,
73 mk_do [vs <+> text "<-" <+> qM rec <+> var 'n' <+> v
74 | v <- vars | vs <- varss]
75 $ text "return $" <+> con "MV" <+> var 'n' <+> sep varss)
76
77 gen_unsafeRead rec
78 = (pat "MV" <+> var 'i',
79 mk_do [v <+> text "<-" <+> qM rec <+> vs <+> var 'i' | v <- vars
80 | vs <- varss]
81 $ text "return" <+> tuple id)
82
83 gen_unsafeWrite rec
84 = (pat "MV" <+> var 'i' <+> tuple id,
85 mk_do [qM rec <+> vs <+> var 'i' <+> v | v <- vars | vs <- varss]
86 empty)
87
88 gen_clear rec
89 = (pat "MV", mk_do [qM rec <+> vs | vs <- varss] empty)
90
91 gen_set rec
92 = (pat "MV" <+> tuple id,
93 mk_do [qM rec <+> vs <+> v | vs <- varss | v <- vars] empty)
94
95 gen_unsafeCopy rec
96 = (patn "MV" 1 <+> patn "MV" 2,
97 mk_do [qM rec <+> vs <> char '1' <+> vs <> char '2' | vs <- varss]
98 empty)
99
100 gen_unsafeGrow rec
101 = (pat "MV" <+> var 'm',
102 mk_do [qM rec <+> vs <+> var 'm' | vs <- varss]
103 $ text "return $" <+> con "MV"
104 <+> parens (var 'm' <> char '+' <> var 'n')
105 <+> sep varss)
106
107 gen_unsafeFreeze rec
108 = (pat "MV",
109 mk_do [vs <> char '\'' <+> text "<-" <+> qG rec <+> vs | vs <- varss]
110 $ text "return $" <+> con "V" <+> var 'n'
111 <+> sep [vs <> char '\'' | vs <- varss])
112
113 gen_basicUnsafeIndexM rec
114 = (pat "V" <+> var 'i',
115 mk_do [v <+> text "<-" <+> qG rec <+> vs <+> var 'i'
116 | vs <- varss | v <- vars]
117 $ text "return" <+> tuple id)
118
119
120
121
122 mk_do cmds ret = hang (text "do")
123 2
124 $ vcat $ cmds ++ [ret]
125
126 method (s, f) = case f s of
127 (p,e) -> text "{-# INLINE" <+> text s <+> text " #-}"
128 $$ hang (text s <+> p)
129 4
130 (char '=' <+> e)
131
132
133 methods_MVector = [("basicLength", gen_length "MV")
134 ,("basicUnsafeSlice", gen_unsafeSlice "M" "MV")
135 ,("basicOverlaps", gen_overlaps)
136 ,("basicUnsafeNew", gen_unsafeNew)
137 ,("basicUnsafeNewWith", gen_unsafeNewWith)
138 ,("basicUnsafeRead", gen_unsafeRead)
139 ,("basicUnsafeWrite", gen_unsafeWrite)
140 ,("basicClear", gen_clear)
141 ,("basicSet", gen_set)
142 ,("basicUnsafeCopy", gen_unsafeCopy)
143 ,("basicUnsafeGrow", gen_unsafeGrow)]
144
145 methods_Vector = [("unsafeFreeze", gen_unsafeFreeze)
146 ,("basicLength", gen_length "V")
147 ,("basicUnsafeSlice", gen_unsafeSlice "G" "V")
148 ,("basicUnsafeIndexM", gen_basicUnsafeIndexM)]