29 data RenderState = RenderState |
29 data RenderState = RenderState |
30 { |
30 { |
31 currentScope :: [Record], |
31 currentScope :: [Record], |
32 lastIdentifier :: String, |
32 lastIdentifier :: String, |
33 lastType :: BaseType, |
33 lastType :: BaseType, |
|
34 stringConsts :: [(String, String)], |
|
35 uniqCounter :: Int, |
34 namespaces :: Map.Map String [Record] |
36 namespaces :: Map.Map String [Record] |
35 } |
37 } |
36 |
38 |
37 emptyState = RenderState [] "" BTUnknown |
39 emptyState = RenderState [] "" BTUnknown [] 0 |
|
40 |
|
41 getUniq :: State RenderState Int |
|
42 getUniq = do |
|
43 i <- gets uniqCounter |
|
44 modify(\s -> s{uniqCounter = uniqCounter s + 1}) |
|
45 return i |
|
46 |
|
47 addStringConst :: String -> State RenderState Doc |
|
48 addStringConst str = do |
|
49 i <- getUniq |
|
50 let sn = "__str" ++ show i |
|
51 modify (\s -> s{stringConsts = (sn, str) : stringConsts s}) |
|
52 return $ text sn |
|
53 |
|
54 escapeStr :: String -> String |
|
55 escapeStr = foldr escapeChar [] |
|
56 |
|
57 escapeChar :: Char -> ShowS |
|
58 escapeChar '"' s = "\\\"" ++ s |
|
59 escapeChar a s = a : s |
|
60 |
|
61 renderStringConsts :: State RenderState Doc |
|
62 renderStringConsts = liftM (vcat . map (\(a, b) -> text "STRCONSTDECL" <> parens (text a <> comma <+> doubleQuotes (text $ escapeStr b)) <> semi)) |
|
63 $ gets stringConsts |
38 |
64 |
39 docToLower :: Doc -> Doc |
65 docToLower :: Doc -> Doc |
40 docToLower = text . map toLower . render |
66 docToLower = text . map toLower . render |
41 |
67 |
42 pas2C :: String -> IO () |
68 pas2C :: String -> IO () |
92 |
118 |
93 withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a |
119 withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a |
94 withState' f sf = do |
120 withState' f sf = do |
95 st <- liftM f get |
121 st <- liftM f get |
96 let (a, s) = runState sf st |
122 let (a, s) = runState sf st |
97 modify(\st -> st{lastType = lastType s}) |
123 modify(\st -> st{ |
|
124 lastType = lastType s |
|
125 , uniqCounter = uniqCounter s |
|
126 , stringConsts = stringConsts s |
|
127 }) |
98 return a |
128 return a |
99 |
129 |
100 withLastIdNamespace :: State RenderState Doc -> State RenderState Doc |
130 withLastIdNamespace :: State RenderState Doc -> State RenderState Doc |
101 withLastIdNamespace f = do |
131 withLastIdNamespace f = do |
102 li <- gets lastIdentifier |
132 li <- gets lastIdentifier |
146 |
176 |
147 interface2C :: Interface -> State RenderState Doc |
177 interface2C :: Interface -> State RenderState Doc |
148 interface2C (Interface uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars) |
178 interface2C (Interface uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars) |
149 |
179 |
150 implementation2C :: Implementation -> State RenderState Doc |
180 implementation2C :: Implementation -> State RenderState Doc |
151 implementation2C (Implementation uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars) |
181 implementation2C (Implementation uses tvars) = do |
|
182 u <- uses2C uses |
|
183 tv <- typesAndVars2C True tvars |
|
184 r <- renderStringConsts |
|
185 return (u $+$ r $+$ tv) |
152 |
186 |
153 |
187 |
154 typesAndVars2C :: Bool -> TypesAndVars -> State RenderState Doc |
188 typesAndVars2C :: Bool -> TypesAndVars -> State RenderState Doc |
155 typesAndVars2C b (TypesAndVars ts) = liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b) ts |
189 typesAndVars2C b (TypesAndVars ts) = liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b) ts |
156 |
190 |
559 (o, _) -> return $ parens e1 <+> text o <+> parens e2 |
593 (o, _) -> return $ parens e1 <+> text o <+> parens e2 |
560 expr2C (NumberLiteral s) = return $ text s |
594 expr2C (NumberLiteral s) = return $ text s |
561 expr2C (FloatLiteral s) = return $ text s |
595 expr2C (FloatLiteral s) = return $ text s |
562 expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
596 expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
563 expr2C (StringLiteral [a]) = return . quotes $ text [a] |
597 expr2C (StringLiteral [a]) = return . quotes $ text [a] |
564 expr2C (StringLiteral s) = return $ doubleQuotes $ text s |
598 expr2C (StringLiteral s) = addStringConst s |
565 expr2C (Reference ref) = ref2C ref |
599 expr2C (Reference ref) = ref2C ref |
566 expr2C (PrefixOp op expr) = liftM (text (op2C op) <>) (expr2C expr) |
600 expr2C (PrefixOp op expr) = liftM (text (op2C op) <>) (expr2C expr) |
567 expr2C Null = return $ text "NULL" |
601 expr2C Null = return $ text "NULL" |
568 expr2C (CharCode a) = return $ quotes $ text "\\x" <> text (showHex (read a) "") |
602 expr2C (CharCode a) = return $ quotes $ text "\\x" <> text (showHex (read a) "") |
569 expr2C (HexCharCode a) = return $ quotes $ text "\\x" <> text (map toLower a) |
603 expr2C (HexCharCode a) = return $ quotes $ text "\\x" <> text (map toLower a) |