Make GHC-in-GHCi work on Windows
[ghc.git] / testsuite / tests / typecheck / should_compile / T2045.hs
1 {-# LANGUAGE EmptyDataDecls #-}
2 {-# OPTIONS_GHC -fno-warn-type-defaults #-}
3
4 -- #2045
5 -- ghc -fhpc --make Vhdl.hs -o gencirc -Wall
6
7 module ShouleCompile where
8
9 writeDefinitions :: Generic b
10 => b -> IO ()
11 writeDefinitions out =
12 do let define v s =
13 case s of
14 Bool True -> port "vcc" []
15 Bool False -> port "gnd" []
16 Inv x -> port "inv" [x]
17
18 And [] -> define v (Bool True)
19 And [x] -> port "id" [x]
20 And [x,y] -> port "and2" [x,y]
21 And (x:xs) -> define (w 0) (And xs)
22 >> define v (And [x,w 0])
23
24 Or [] -> define v (Bool False)
25 Or [x] -> port "id" [x]
26 Or [x,y] -> port "or2" [x,y]
27 Or (x:xs) -> define (w 0) (Or xs)
28 >> define v (Or [x,w 0])
29
30 Xor [] -> define v (Bool False)
31 Xor [x] -> port "id" [x]
32 Xor [x,y] -> port "xor2" [x,y]
33 Xor (x:xs) -> define (w 0) (Or xs)
34 >> define (w 1) (Inv (w 0))
35 >> define (w 2) (And [x, w 1])
36
37 >> define (w 3) (Inv x)
38 >> define (w 4) (Xor xs)
39 >> define (w 5) (And [w 3, w 4])
40 >> define v (Or [w 2, w 5])
41
42 Multi a1 a2 a3 a4 -> multi a1 a2 a3 a4
43 where
44 w i = v ++ "_" ++ show i
45
46 multi n "RAMB16_S18" opts args =
47 do putStr $
48 " "
49 ++ " : "
50 ++ "RAMB16_S18"
51 ++ "\ngeneric map ("
52 ++ opts
53 ++ mapTo "DOP" [0,1] (get 16 2 outs)
54 ++ mapTo "ADDR" [0..9] (get 0 10 args)
55 where
56 outs = map (\i -> "o" ++ show i ++ "_" ++ v) [1..n]
57
58 get :: Int -> Int -> [a] -> [a]
59 get n' m xs = take m (drop n' xs)
60
61 mapTo s' (n':ns) (x:xs) = s' ++ "(" ++ show n' ++ ")"
62 ++ " => " ++ x ++ ",\n"
63 ++ mapTo s' ns xs
64 mapTo _ _ _ = ""
65
66
67
68 multi n "RAMB16_S18_S18" opts args =
69 do putStr $
70 opts
71 ++ mapTo "DOA" [0..15] (get 0 16 outs)
72 ++ mapTo "DOB" [0..15] (get 18 16 outs)
73 ++ mapTo "DOPA" [0,1] (get 16 2 outs)
74 ++ mapTo "DOPB" [0,1] (get 34 2 outs)
75 ++ mapTo "ADDRA" [0..9] (get 0 10 args)
76 ++ mapTo "ADDRB" [0..9] (get 10 10 args)
77 ++ mapTo "DIA" [0..15] (get 20 16 args)
78 ++ mapTo "DIB" [0..15] (get 38 16 args)
79 ++ mapTo "DIPA" [0,1] (get 36 2 args)
80 ++ mapTo "DIPB" [0,1] (get 54 2 args)
81 ++ head (get 56 1 args)
82 ++ head (get 57 1 args)
83 where
84 outs = map (\i -> "o" ++ show i ++ "_" ++ v) [1..n]
85
86 get :: Int -> Int -> [a] -> [a]
87 get _ _ = id
88
89 mapTo s' (n':ns) (x:xs) = s' ++ "(" ++ show n' ++ ")"
90 ++ " => " ++ x ++ ",\n"
91 ++ mapTo s' ns xs
92 mapTo _ _ _ = ""
93 multi _ _ _ _ = undefined
94
95 port n args | n == "id" =
96 do putStr $
97 " "
98 ++ v ++ " <= " ++ (head args) ++ ";\n"
99
100 port _ _ = undefined
101 netlistIO define (struct out)
102 return ()
103
104 netlistIO :: (v -> S v -> IO ()) -> f Symbol -> IO (f v)
105 netlistIO = undefined
106
107 data Struct a
108
109 class Generic a where
110 struct :: a -> Struct Symbol
111 struct = undefined
112
113 instance Generic (Signal a)
114
115 data Signal a
116
117 data Symbol
118
119 data S s
120 = Bool Bool
121 | Inv s
122 | And [s]
123 | Or [s]
124 | Xor [s]
125 | Multi Int String String [s]
126