Permalink
Browse files

first approach - not working

  • Loading branch information...
1 parent 7a23de8 commit fc6e8fd2f58a9f023590ec252191930b85e85364 Alexander Bernauer committed Oct 10, 2012
Showing with 63 additions and 56 deletions.
  1. +63 −56 ocram/src/Ocram/Print.hs
View
@@ -33,18 +33,20 @@
-- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-- SUCH DAMAGE.
-- }}}1
-{-# LANGUAGE FlexibleInstances, TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances, TemplateHaskell, MultiParamTypeClasses #-}
module Ocram.Print
-- export {{{1
(
print_with_log, pretty
) where
-- import {{{1
+import Control.Applicative ((<$>), (<*>))
+import Data.Monoid (Monoid)
import Language.C.Data.Position (posRow)
import Language.C.Syntax
import Language.C.Data.Ident (Ident, identToString)
-import Language.C.Data.Node (posOfNode, isUndefNode)
+import Language.C.Data.Node (posOfNode, isUndefNode, NodeInfo)
import Text.PrettyPrint
import Ocram.Debug (ENodeInfo(..), Breakpoint(..), Breakpoints)
import Ocram.Ruab (ERow(..), TRow(..))
@@ -53,61 +55,66 @@ import Prelude hiding (log)
import qualified Data.ByteString.Char8 as BS
-print_with_log :: CTranslationUnit ENodeInfo -> (BS.ByteString, Breakpoints) -- {{{1
-print_with_log tu =
+print_with_log :: (Monoid m, PrettyLog a m) => a -> (BS.ByteString, m) -- {{{1
+print_with_log o =
let
- (code, log) = renderWithLog (pretty tu)
+ (code, log) = renderWithLog (pretty o)
in
(BS.pack code, log)
-type Log = Breakpoints -- {{{2
-
-marker :: ENodeInfo -> DocL Log -> DocL Log -- {{{2
-marker eni doc =
- let
- doc' = if enBreakpoint eni then here bpLogger doc else doc
- in
- if (isUndefNode . enTnodeInfo) eni
- then doc
- else doc'
- where
- bpLogger (Position r _) = [Breakpoint trow (ERow r) (enThreadId eni) (enBlockingCall eni)]
- trow = TRow . posRow . posOfNode . enTnodeInfo $ eni
+marker :: (Monoid m, MarkerInfo i m) => i -> DocL m -> DocL m -- {{{2
+marker mi doc
+ | addMarker mi = here (getLogger mi) doc
+ | otherwise = doc
-class PrettyLog a where -- {{{2
- pretty :: a -> DocL Log
- prettyPrec :: Int -> a -> DocL Log
+class Monoid m => PrettyLog a m where -- {{{2
+ pretty :: a -> DocL m
+ prettyPrec :: Int -> a -> DocL m
pretty = prettyPrec 0
prettyPrec _ = pretty
+class Monoid m => MarkerInfo a m where -- {{{2
+ addMarker :: a -> Bool
+ getLogger :: a -> Logger m
+
+instance MarkerInfo NodeInfo () where
+ addMarker = const False
+ getLogger = undefined
+
+instance MarkerInfo ENodeInfo [Breakpoint] where
+ addMarker = (&&) <$> not . isUndefNode . enTnodeInfo <*> enBreakpoint
+ getLogger eni (Position r _) = [Breakpoint trow (ERow r) (enThreadId eni) (enBlockingCall eni)]
+ where
+ trow = TRow . posRow . posOfNode . enTnodeInfo $ eni
+
-- utils {{{2
-maybeP :: (p -> DocL Log) -> Maybe p -> DocL Log -- {{{3
+maybeP :: (p -> DocL m) -> Maybe p -> DocL m -- {{{3
-- pretty print optional chunk
maybeP = maybe empty
-ifP :: Bool -> DocL Log -> DocL Log -- {{{3
+ifP :: Bool -> DocL m -> DocL m -- {{{3
-- pretty print when flag is true
ifP flag doc = if flag then doc else empty
-mlistP :: ([p] -> DocL Log) -> [p] -> DocL Log -- {{{3
+mlistP :: ([p] -> DocL m) -> [p] -> DocL m -- {{{3
-- pretty print _optional_ list, i.e. [] ~ Nothing and (x:xs) ~ Just (x:xs)
mlistP pp xs = maybeP pp (if null xs then Nothing else Just xs)
-identP :: Ident -> DocL Log -- {{{3
+identP :: Ident -> DocL m -- {{{3
-- pretty print identifier
identP = text . identToString
-attrlistP :: [CAttribute ENodeInfo] -> DocL Log -- {{{3
+attrlistP :: (Monoid m, MarkerInfo i m) => [CAttribute i] -> DocL m -- {{{3
-- pretty print attribute annotations
attrlistP [] = empty
attrlistP attrs = text "__attribute__" <> parens (parens (hcat . punctuate comma . map pretty $ attrs))
-parenPrec :: Int -> Int -> DocL Log -> DocL Log -- {{{3
+parenPrec :: Monoid m => Int -> Int -> DocL m -> DocL m -- {{{3
-- analogous to showParen
parenPrec prec prec2 t = if prec <= prec2 then t else parens t
-ii :: DocL Log -> DocL Log -- {{{3
+ii :: DocL m -> DocL m -- {{{3
-- indent a chunk of code
ii = nest 4
@@ -133,16 +140,16 @@ binPrec CLndOp = 12
binPrec CLorOp = 11
-- PrettyLog instances {{{2
-instance PrettyLog (CTranslationUnit ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CTranslationUnit i) m where -- {{{3
pretty (CTranslUnit edecls ni) = marker ni $ vcat (map pretty edecls)
-- TODO: Check need of __extension__
-instance PrettyLog (CExternalDeclaration ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CExternalDeclaration i) m where -- {{{3
pretty (CDeclExt decl) = pretty decl <> semi
pretty (CFDefExt fund) = pretty fund
pretty (CAsmExt asmStmt ni) = marker ni $ text "asm" <> parens (pretty asmStmt) <> semi
-instance PrettyLog (CFunctionDef ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CFunctionDef i) m where -- {{{3
-- TODO: Check that old-style and new-style aren't mixed
pretty (CFunDef declspecs declr decls stat ni) = marker ni $
hsep (map pretty declspecs)
@@ -151,7 +158,7 @@ instance PrettyLog (CFunctionDef ENodeInfo) where -- {{{3
$$ prettyPrec (-1) stat
-instance PrettyLog (CStatement ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CStatement i) m where -- {{{3
pretty (CLabel ident stat cattrs ni) = marker ni $ identP ident <> text ":" <+> attrlistP cattrs $$ pretty stat
pretty (CCase expr stat ni) = marker ni $ text "case" <+> pretty expr <> text ":" $$ pretty stat
@@ -205,7 +212,7 @@ instance PrettyLog (CStatement ENodeInfo) where -- {{{3
prettyPrec _ p = pretty p
-instance PrettyLog (CAssemblyStatement ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CAssemblyStatement i) m where -- {{{3
pretty (CAsmStmt tyQual expr outOps inOps clobbers ni) = marker ni $
ii $ text "__asm__" <+>
maybeP pretty tyQual <>
@@ -218,20 +225,20 @@ instance PrettyLog (CAssemblyStatement ENodeInfo) where -- {{{3
(if null clobbers then empty else clobs)
clobs = text ":" <+> hcat (punctuate comma (map pretty clobbers))
-instance PrettyLog (CAssemblyOperand ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CAssemblyOperand i) m where -- {{{3
-- asm_operand :~ [operand-name] "constraint" ( expr )
pretty (CAsmOperand mArgName cnstr expr ni) = marker ni $
maybeP (\argName -> text "[" <> identP argName <> text "]") mArgName <+>
pretty cnstr <+>
parens (pretty expr)
-- TODO: Check need of __extension__
-instance PrettyLog (CCompoundBlockItem ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CCompoundBlockItem i) m where -- {{{3
pretty (CBlockStmt stat) = pretty stat
pretty (CBlockDecl decl) = ii $ pretty decl <> semi
pretty (CNestedFunDef fundef) = ii $ pretty fundef
-instance PrettyLog (CDeclaration ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CDeclaration i) m where -- {{{3
-- CAVEAT:
-- we may not print __attribute__s directly after typespecs,
-- as this may change the semantics of the declaration.
@@ -258,20 +265,20 @@ instance PrettyLog (CDeclaration ENodeInfo) where -- {{{3
getAttrs Nothing = []
getAttrs (Just (CDeclr _ _ _ cattrs _)) = cattrs
-instance PrettyLog (CDeclarationSpecifier ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CDeclarationSpecifier i) m where -- {{{3
pretty (CStorageSpec sp) = pretty sp
pretty (CTypeSpec sp) = pretty sp
pretty (CTypeQual qu) = pretty qu
-instance PrettyLog (CStorageSpecifier ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CStorageSpecifier i) m where -- {{{3
pretty (CAuto ni) = marker ni $ text "auto"
pretty (CRegister ni) = marker ni $ text "register"
pretty (CStatic ni) = marker ni $ text "static"
pretty (CExtern ni) = marker ni $ text "extern"
pretty (CTypedef ni) = marker ni $ text "typedef"
pretty (CThread ni) = marker ni $ text "__thread"
-instance PrettyLog (CTypeSpecifier ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CTypeSpecifier i) m where -- {{{3
pretty (CVoidType ni) = marker ni $ text "void"
pretty (CCharType ni) = marker ni $ text "char"
pretty (CShortType ni) = marker ni $ text "short"
@@ -289,23 +296,23 @@ instance PrettyLog (CTypeSpecifier ENodeInfo) where -- {{{3
pretty (CTypeOfExpr expr ni) = marker ni $ text "typeof" <> text "(" <> pretty expr <> text ")"
pretty (CTypeOfType decl ni) = marker ni $ text "typeof" <> text "(" <> pretty decl <> text ")"
-instance PrettyLog (CTypeQualifier ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CTypeQualifier i) m where -- {{{3
pretty (CConstQual ni) = marker ni $ text "const"
pretty (CVolatQual ni) = marker ni $ text "volatile"
pretty (CRestrQual ni) = marker ni $ text "__restrict"
pretty (CInlineQual ni) = marker ni $ text "inline"
pretty (CAttrQual a) = attrlistP [a]
-instance PrettyLog (CStructureUnion ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CStructureUnion i) m where -- {{{3
pretty (CStruct tag ident Nothing cattrs ni) = marker ni $ pretty tag <+> attrlistP cattrs <+> maybeP identP ident
pretty (CStruct tag ident (Just []) cattrs ni) = marker ni $ pretty tag <+> attrlistP cattrs <+> maybeP identP ident <+> text "{ }"
pretty (CStruct tag ident (Just decls) cattrs ni) = marker ni $ vcat [pretty tag <+> attrlistP cattrs <+> maybeP identP ident <+> text "{", ii $ sep (map (<> semi) (map pretty decls)), text "}"]
-instance PrettyLog CStructTag where -- {{{3
+instance Monoid m => PrettyLog CStructTag m where -- {{{3
pretty CStructTag = text "struct"
pretty CUnionTag = text "union"
-instance PrettyLog (CEnumeration ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CEnumeration i) m where -- {{{3
pretty (CEnum enum_ident Nothing cattrs ni) = marker ni $ text "enum" <+> attrlistP cattrs <+> maybeP identP enum_ident
pretty (CEnum enum_ident (Just vals) cattrs ni) = marker ni $ vcat [text "enum" <+> attrlistP cattrs <+> maybeP identP enum_ident <+> text "{", ii $ sep (punctuate comma (map p vals)), text "}"]
where
@@ -346,10 +353,10 @@ instance PrettyLog (CEnumeration ENodeInfo) where -- {{{3
-- prettyList :: (Pretty a) => [a] -> Doc
-- prettyList = hsep . punctuate comma . map pretty
-instance PrettyLog (CDeclarator ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CDeclarator i) m where -- {{{3
prettyPrec prec declr = marker (annotation declr) $ prettyDeclr True prec declr
-prettyDeclr :: Bool -> Int -> CDeclarator ENodeInfo -> DocL Log -- {{{4
+prettyDeclr :: (Monoid m, MarkerInfo i m) => Bool -> Int -> CDeclarator i -> DocL m -- {{{4
prettyDeclr show_attrs prec (CDeclr name derived_declrs asmname cattrs _) =
ppDeclr prec (reverse derived_declrs) <+> prettyAsmName asmname <+> ifP show_attrs (attrlistP cattrs)
where
@@ -374,14 +381,14 @@ prettyDeclr show_attrs prec (CDeclr name derived_declrs asmname cattrs _) =
prettyAsmName asm_name_opt
= maybe empty (\asm_name -> text "__asm__" <> parens (pretty asm_name)) asm_name_opt
-instance PrettyLog (CArraySize ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CArraySize i) m where -- {{{3
pretty (CNoArrSize completeType) = ifP completeType (text "*")
pretty (CArrSize staticMod expr) = ifP staticMod (text "static") <+> pretty expr
-- initializer :: { CInit }
-- initializer :- assignment_expression
-- | '{' (designation? initializer)_cs_list '}'
-instance PrettyLog (CInitializer ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CInitializer i) m where -- {{{3
pretty (CInitExpr expr ni) = marker ni $ pretty expr
pretty (CInitList initl ni) = marker ni $ text "{" <+> hsep (punctuate comma (map p initl)) <+> text "}"
where
@@ -394,16 +401,16 @@ instance PrettyLog (CInitializer ENodeInfo) where -- {{{3
-- member_designator :- '.' identifier
-- arr_range _designator :- '[' constant_expression "..." constant_expression ']'
-instance PrettyLog (CPartDesignator ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CPartDesignator i) m where -- {{{3
pretty (CArrDesig expr ni) = marker ni $ text "[" <> pretty expr <> text "]"
pretty (CMemberDesig ident ni) = marker ni $ text "." <> identP ident
pretty (CRangeDesig expr1 expr2 ni) = marker ni $ text "[" <> pretty expr1 <+> text "..." <+> pretty expr2 <> text "]"
-instance PrettyLog (CAttribute ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CAttribute i) m where -- {{{3
pretty (CAttr attrName [] ni) = marker ni $ identP attrName
pretty (CAttr attrName attrParams ni) = marker ni $ identP attrName <> parens (hsep . punctuate comma . map pretty $ attrParams)
-instance PrettyLog (CExpression ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CExpression i) m where -- {{{3
prettyPrec p (CComma exprs ni) = marker ni $ parenPrec p (-1) $ hsep (punctuate comma (map (prettyPrec 2) exprs))
prettyPrec p (CAssign op expr1 expr2 ni) = marker ni $ parenPrec p 2 $ prettyPrec 3 expr1 <+> pretty op <+> prettyPrec 2 expr2
@@ -458,7 +465,7 @@ instance PrettyLog (CExpression ENodeInfo) where -- {{{3
prettyPrec _p (CBuiltinExpr builtin) = pretty builtin
-instance PrettyLog (CBuiltinThing ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CBuiltinThing i) m where -- {{{3
pretty (CBuiltinVaArg expr ty_name ni) = marker ni $ text "__builtin_va_arg" <+> (parens $ pretty expr <> comma <+> pretty ty_name)
-- The first desig has to be a member field.
@@ -468,7 +475,7 @@ instance PrettyLog (CBuiltinThing ENodeInfo) where -- {{{3
pretty (CBuiltinTypesCompatible ty1 ty2 ni) = marker ni $ text "__builtin_types_compatible_p" <+> (parens $ pretty ty1 <> comma <+> pretty ty2)
-instance PrettyLog CAssignOp where -- {{{3
+instance Monoid m => PrettyLog CAssignOp m where -- {{{3
pretty op = text $ case op of
CAssignOp -> "="
CMulAssOp -> "*="
@@ -482,7 +489,7 @@ instance PrettyLog CAssignOp where -- {{{3
CXorAssOp -> "^="
COrAssOp -> "|="
-instance PrettyLog CBinaryOp where -- {{{3
+instance Monoid m => PrettyLog CBinaryOp m where -- {{{3
pretty op = text $ case op of
CMulOp -> "*"
CDivOp -> "/"
@@ -503,7 +510,7 @@ instance PrettyLog CBinaryOp where -- {{{3
CLndOp -> "&&"
CLorOp -> "||"
-instance PrettyLog CUnaryOp where -- {{{3
+instance Monoid m => PrettyLog CUnaryOp m where -- {{{3
pretty op = text $ case op of
CPreIncOp -> "++"
CPreDecOp -> "--"
@@ -516,12 +523,12 @@ instance PrettyLog CUnaryOp where -- {{{3
CCompOp -> "~"
CNegOp -> "!"
-instance PrettyLog (CConstant ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CConstant i) m where -- {{{3
pretty (CIntConst int_const ni) = marker ni $ text (show int_const)
pretty (CCharConst chr ni) = marker ni $ text (show chr)
pretty (CFloatConst flt ni) = marker ni $ text (show flt)
pretty (CStrConst str ni) = marker ni $ text (show str)
-instance PrettyLog (CStringLiteral ENodeInfo) where -- {{{3
+instance (Monoid m, MarkerInfo i m) => PrettyLog (CStringLiteral i) m where -- {{{3
pretty (CStrLit str _) = text (show str)

0 comments on commit fc6e8fd

Please sign in to comment.