← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to libraries/Cabal/tests/systemTests/wash2hs/hs/WASHExpression.hs

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
libraries/Cabal/tests/systemTests/wash2hs/hs/WASHExpression.hs
 
1
module WASHExpression where
 
2
 
 
3
import Control.Monad
 
4
 
 
5
import WASHFlags
 
6
import qualified WASHUtil
 
7
import WASHData
 
8
import WASHOut
 
9
 
 
10
code :: FLAGS -> [CodeFrag] -> ShowS
 
11
code flags [] = id
 
12
code flags (x:xs) = code' flags x . code flags xs
 
13
 
 
14
code' :: FLAGS -> CodeFrag -> ShowS
 
15
code' flags (HFrag h) = 
 
16
  showString h
 
17
code' flags (EFrag e) =
 
18
  runOut $ element flags e
 
19
code' flags (CFrag cnts) =
 
20
  showChar '(' .
 
21
  runOut (contents flags [] cnts) .
 
22
  showChar ')'
 
23
code' flags (AFrag attrs) =
 
24
  showChar '(' .
 
25
  WASHUtil.itemList (attribute flags) "CGI.empty" " >> " attrs .
 
26
  showChar ')'
 
27
code' flags (VFrag var) = 
 
28
  id
 
29
code' flags _ = error "Unknown type: code"
 
30
 
 
31
outMode :: Mode -> Out ()
 
32
outMode = outShowS . showMode
 
33
 
 
34
showMode :: Mode -> ShowS
 
35
showMode V = id
 
36
showMode S = showString "_T"
 
37
showMode F = showString "_S"
 
38
 
 
39
element :: FLAGS -> Element -> Out [String]
 
40
element flags (Element mode nm ats cnt et) =
 
41
  do outChar '('
 
42
     outString "CGI."
 
43
     outString nm
 
44
     when (generateBT flags) $ outMode mode
 
45
     outChar '('
 
46
     outShowS $ attributes flags ats
 
47
     rvs <- contents flags [] cnt
 
48
     outString "))"
 
49
     return rvs
 
50
 
 
51
outRVS :: [String] -> Out ()
 
52
outRVS [] = outString "()"
 
53
outRVS (x:xs) =
 
54
  do outChar '('
 
55
     outString x
 
56
     mapM_ g xs
 
57
     outChar ')'
 
58
  where g x = do { outChar ','; outString x; }
 
59
 
 
60
outRVSpat :: [String] -> Out ()
 
61
outRVSpat [] = outString "(_)"
 
62
outRVSpat xs = outRVS xs
 
63
 
 
64
contents :: FLAGS -> [String] -> [Content] -> Out [String]
 
65
contents flags inRVS cts =
 
66
  case cts of
 
67
    [] ->
 
68
      do outString "return"
 
69
         outRVS inRVS
 
70
         return inRVS
 
71
    ct:cts ->
 
72
      do rvs <- content flags ct
 
73
         case rvs of
 
74
           [] ->
 
75
             case (cts, inRVS) of
 
76
               ([],[]) ->
 
77
                 return []
 
78
               _ ->
 
79
                 do outString " >> "
 
80
                    contents flags inRVS cts
 
81
           _ ->
 
82
             case (cts, inRVS) of
 
83
               ([],[]) ->
 
84
                 return rvs
 
85
               _ ->
 
86
                 do outString " >>= \\ "
 
87
                    outRVSpat rvs
 
88
                    outString " -> "
 
89
                    contents flags (rvs ++ inRVS) cts
 
90
 
 
91
content :: FLAGS -> Content -> Out [String]
 
92
content flags (CElement elem)  = 
 
93
  element flags elem
 
94
content flags (CText txt) =
 
95
  do text flags txt
 
96
     return []
 
97
content flags (CCode (VFrag var:c)) =
 
98
  do outShowS $ (showChar '(' . code flags c . showChar ')')
 
99
     return [var]
 
100
content flags (CCode c) =
 
101
  do outShowS $ (showChar '(' . code flags c . showChar ')')
 
102
     return []
 
103
content flags (CComment cc) =
 
104
  do outShowS $ (showString "return (const () " . shows cc . showChar ')')
 
105
     return []
 
106
content flags (CReference txt) =
 
107
  do text flags txt
 
108
     return []
 
109
content flags c = 
 
110
  error $ "Unknown type: content -- " ++ (show c)
 
111
 
 
112
text :: FLAGS -> Text -> Out [String]
 
113
text flags txt =
 
114
  do outString "CGI.rawtext"
 
115
     when (generateBT flags) $ outMode (textMode txt)
 
116
     outChar ' '
 
117
     outs (textString txt)
 
118
     return []
 
119
 
 
120
attributes :: FLAGS -> [Attribute] -> ShowS
 
121
attributes flags atts = 
 
122
  f atts
 
123
    where
 
124
      f [] = id
 
125
      f (att:atts) = 
 
126
        attribute flags att .
 
127
        showString " >> " .
 
128
        f atts
 
129
 
 
130
attribute :: FLAGS -> Attribute -> ShowS
 
131
attribute flags (Attribute m n v) = 
 
132
  showString "(CGI.attr" .
 
133
  (if generateBT flags then (attrvalueBT m v) else id) .
 
134
  showChar ' ' .
 
135
  shows n . 
 
136
  showString " " .
 
137
  attrvalue v .
 
138
  showString ")"
 
139
attribute flags (AttrPattern pat) =
 
140
  showString "( " .
 
141
  showString pat .
 
142
  showString " )"
 
143
attribute flags a = error $ "Unknown type: attribute -- " ++ (show a)
 
144
 
 
145
attrvalue :: AttrValue -> ShowS
 
146
attrvalue (AText t) = 
 
147
  shows t
 
148
attrvalue (ACode c) =
 
149
  showString "( " .
 
150
  showString c .
 
151
  showString " )"
 
152
attrvalue a = error $ "Unknown type: attrvalue -- " ++ (show a)
 
153
 
 
154
attrvalueBT :: Mode -> AttrValue -> ShowS
 
155
attrvalueBT V _ = id
 
156
attrvalueBT m (AText _) = showMode m . showChar 'S'
 
157
attrvalueBT m (ACode _) = showMode m . showChar 'D'
 
158
attrvalueBT m a = error $ "Unknown type: attrvalueBT -- " ++ (show a)