321 tvar2C f (OperatorDeclaration op i ret params body) = |
323 tvar2C f (OperatorDeclaration op i ret params body) = |
322 tvar2C f (FunctionDeclaration i ret params body) |
324 tvar2C f (FunctionDeclaration i ret params body) |
323 |
325 |
324 |
326 |
325 initExpr2C :: InitExpression -> State RenderState Doc |
327 initExpr2C :: InitExpression -> State RenderState Doc |
|
328 initExpr2C InitNull = return $ text "NULL" |
|
329 initExpr2C (InitAddress expr) = liftM ((<>) (text "&")) (initExpr2C expr) |
|
330 initExpr2C (InitPrefixOp op expr) = liftM2 (<>) (op2C op) (initExpr2C expr) |
326 initExpr2C (InitBinOp op expr1 expr2) = do |
331 initExpr2C (InitBinOp op expr1 expr2) = do |
327 e1 <- initExpr2C expr1 |
332 e1 <- initExpr2C expr1 |
328 e2 <- initExpr2C expr2 |
333 e2 <- initExpr2C expr2 |
329 o <- op2C op |
334 o <- op2C op |
330 return $ parens $ e1 <+> o <+> e2 |
335 return $ parens $ e1 <+> o <+> e2 |
331 initExpr2C (InitNumber s) = return $ text s |
336 initExpr2C (InitNumber s) = return $ text s |
332 initExpr2C (InitFloat s) = return $ text s |
337 initExpr2C (InitFloat s) = return $ text s |
333 initExpr2C (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
338 initExpr2C (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
334 initExpr2C (InitString s) = return $ doubleQuotes $ text s |
339 initExpr2C (InitString s) = return $ doubleQuotes $ text s |
|
340 initExpr2C (InitChar a) = return $ quotes $ text "\\x" <> text (showHex (read a) "") |
335 initExpr2C (InitReference i) = id2C IOLookup i |
341 initExpr2C (InitReference i) = id2C IOLookup i |
336 initExpr2C _ = return $ text "<<expression>>" |
342 initExpr2C (InitRecord fields) = do |
|
343 (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields |
|
344 return $ lbrace $+$ (nest 4 . vcat $ fs) $+$ rbrace |
|
345 initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values |
|
346 initExpr2C (InitRange _) = return $ text "<<range expression>>" |
|
347 initExpr2C (InitSet _) = return $ text "<<set>>" |
|
348 initExpr2C (BuiltInFunction {}) = return $ text "<<built-in function>>" |
|
349 initExpr2C a = error $ "Don't know how to render " ++ show a |
337 |
350 |
338 |
351 |
339 type2C :: TypeDecl -> State RenderState Doc |
352 type2C :: TypeDecl -> State RenderState Doc |
340 type2C (SimpleType i) = id2C IOLookup i |
353 type2C (SimpleType i) = id2C IOLookup i |
341 type2C t = do |
354 type2C t = do |
348 type2C' (String l) = return $ text $ "string" ++ show l |
361 type2C' (String l) = return $ text $ "string" ++ show l |
349 type2C' (PointerTo (SimpleType i)) = liftM (<> text "*") $ id2C IODeferred i |
362 type2C' (PointerTo (SimpleType i)) = liftM (<> text "*") $ id2C IODeferred i |
350 type2C' (PointerTo t) = liftM (<> text "*") $ type2C t |
363 type2C' (PointerTo t) = liftM (<> text "*") $ type2C t |
351 type2C' (RecordType tvs union) = do |
364 type2C' (RecordType tvs union) = do |
352 t <- withState' id $ mapM (tvar2C False) tvs |
365 t <- withState' id $ mapM (tvar2C False) tvs |
353 return $ text "{" $+$ (nest 4 . vcat $ t) $+$ text "}" |
366 return $ lbrace $+$ (nest 4 . vcat $ t) $+$ rbrace |
354 type2C' (RangeType r) = return $ text "<<range type>>" |
367 type2C' (RangeType r) = return $ text "<<range type>>" |
355 type2C' (Sequence ids) = do |
368 type2C' (Sequence ids) = do |
356 mapM_ (id2C IOInsert) ids |
369 mapM_ (id2C IOInsert) ids |
357 return $ text "<<sequence type>>" |
370 return $ text "<<sequence type>>" |
358 type2C' (ArrayDecl r t) = return $ text "<<array type>>" |
371 type2C' (ArrayDecl r t) = do |
|
372 t' <- type2C t |
|
373 return $ t' <> brackets (text "<<range>>") |
359 type2C' (Set t) = return $ text "<<set>>" |
374 type2C' (Set t) = return $ text "<<set>>" |
360 type2C' (FunctionType returnType params) = return $ text "<<function>>" |
375 type2C' (FunctionType returnType params) = return $ text "<<function>>" |
361 type2C' (DeriveType _) = return $ text "<<type derived from constant literal>>" |
376 type2C' (DeriveType (InitBinOp {})) = return $ text "int" |
|
377 type2C' (DeriveType (InitPrefixOp _ i)) = type2C' (DeriveType i) |
|
378 type2C' (DeriveType (InitNumber _)) = return $ text "int" |
|
379 type2C' (DeriveType (InitHexNumber _)) = return $ text "int" |
|
380 type2C' (DeriveType (InitFloat _)) = return $ text "float" |
|
381 type2C' (DeriveType (BuiltInFunction {})) = return $ text "int" |
|
382 type2C' (DeriveType (InitString {})) = return $ text "string255" |
|
383 type2C' (DeriveType (InitReference {})) = return $ text "<<some type>>" |
|
384 type2C' (DeriveType a) = error $ "Can't derive type from " ++ show a |
362 |
385 |
363 phrase2C :: Phrase -> State RenderState Doc |
386 phrase2C :: Phrase -> State RenderState Doc |
364 phrase2C (Phrases p) = do |
387 phrase2C (Phrases p) = do |
365 ps <- mapM phrase2C p |
388 ps <- mapM phrase2C p |
366 return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" |
389 return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" |
439 expr2C (NumberLiteral s) = return $ text s |
462 expr2C (NumberLiteral s) = return $ text s |
440 expr2C (FloatLiteral s) = return $ text s |
463 expr2C (FloatLiteral s) = return $ text s |
441 expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
464 expr2C (HexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
442 expr2C (StringLiteral s) = return $ doubleQuotes $ text s |
465 expr2C (StringLiteral s) = return $ doubleQuotes $ text s |
443 expr2C (Reference ref) = ref2C ref |
466 expr2C (Reference ref) = ref2C ref |
444 expr2C (PrefixOp op expr) = liftM2 (<+>) (op2C op) (expr2C expr) |
467 expr2C (PrefixOp op expr) = liftM2 (<>) (op2C op) (expr2C expr) |
445 expr2C Null = return $ text "NULL" |
468 expr2C Null = return $ text "NULL" |
446 expr2C (BuiltInFunCall params ref) = do |
469 expr2C (BuiltInFunCall params ref) = do |
447 r <- ref2C ref |
470 r <- ref2C ref |
448 ps <- mapM expr2C params |
471 ps <- mapM expr2C params |
449 return $ |
472 return $ |
450 r <> parens (hsep . punctuate (char ',') $ ps) |
473 r <> parens (hsep . punctuate (char ',') $ ps) |
451 expr2C _ = return $ text "<<expression>>" |
474 expr2C (CharCode a) = return $ quotes $ text "\\x" <> text (showHex (read a) "") |
|
475 expr2C (HexCharCode a) = return $ quotes $ text "\\x" <> text (map toLower a) |
|
476 expr2C (SetExpression ids) = mapM (id2C IOLookup) ids >>= return . parens . hcat . punctuate (text " | ") |
|
477 expr2C a = error $ "Don't know how to render " ++ show a |
452 |
478 |
453 |
479 |
454 ref2C :: Reference -> State RenderState Doc |
480 ref2C :: Reference -> State RenderState Doc |
455 -- rewrite into proper form |
481 -- rewrite into proper form |
456 ref2C r@(RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2) |
482 ref2C (RecordField ref1 (ArrayElement exprs ref2)) = ref2C $ ArrayElement exprs (RecordField ref1 ref2) |
457 ref2C r@(RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2) |
483 ref2C (RecordField ref1 (Dereference ref2)) = ref2C $ Dereference (RecordField ref1 ref2) |
458 ref2C r@(RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3 |
484 ref2C (RecordField ref1 (RecordField ref2 ref3)) = ref2C $ RecordField (RecordField ref1 ref2) ref3 |
459 ref2C r@(RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2) |
485 ref2C (RecordField ref1 (FunCall params ref2)) = ref2C $ FunCall params (RecordField ref1 ref2) |
|
486 ref2C (ArrayElement (a:b:xs) ref) = ref2C $ ArrayElement (b:xs) (ArrayElement [a] ref) |
460 -- conversion routines |
487 -- conversion routines |
461 ref2C ae@(ArrayElement exprs ref) = do |
488 ref2C ae@(ArrayElement exprs ref) = do |
462 es <- mapM expr2C exprs |
489 es <- mapM expr2C exprs |
463 r <- ref2C ref |
490 r <- ref2C ref |
464 t <- gets lastType |
491 t <- gets lastType |
465 ns <- gets currentScope |
492 ns <- gets currentScope |
466 case t of |
493 case t of |
467 (BTArray _ ta@(BTArray _ t')) |
|
468 | length exprs == 2 -> modify (\st -> st{lastType = t'}) |
|
469 | length exprs == 1 -> modify (\st -> st{lastType = ta}) |
|
470 | otherwise -> error $ "Array has more than two dimensions" |
|
471 (BTArray _ t') -> modify (\st -> st{lastType = t'}) |
494 (BTArray _ t') -> modify (\st -> st{lastType = t'}) |
472 (BTString) -> modify (\st -> st{lastType = BTChar}) |
495 (BTString) -> modify (\st -> st{lastType = BTChar}) |
473 a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns) |
496 a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae ++ "\n" ++ show (take 100 ns) |
474 return $ r <> (brackets . hcat) (punctuate comma es) |
497 return $ r <> (brackets . hcat) (punctuate comma es) |
475 ref2C (SimpleReference name) = id2C IOLookup name |
498 ref2C (SimpleReference name) = id2C IOLookup name |