NetSurf efforts

1 files changed, 294 insertions, 159 deletions

diff --git a/c2haskell.hs b/c2haskell.hs
index 8397f98..03ba9cd 100644
--- a/c2haskell.hs
+++ b/c2haskell.hs
@@ -1,169 +1,304 @@
+{-# LANGUAGE BangPatterns             #-}
+{-# LANGUAGE FlexibleContexts         #-}
+{-# LANGUAGE LambdaCase               #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE QuasiQuotes              #-}
+{-# LANGUAGE TemplateHaskell          #-}
 
-import Language.C
+import Data.Generics.Aliases
+import Data.Generics.Schemes
+import Debug.Trace
+import Control.Monad
+import Data.Char
+import Data.Data
+import Data.List
+import qualified Data.Map           as Map
+         ;import Data.Map           (Map)
+import Data.Maybe
+import qualified Data.Set           as Set
+         ;import Data.Set           (Set)
+import Language.C.Data.Ident        as C
+import Language.C                   as C hiding (prettyUsingInclude)
 import Language.C.System.GCC
+import Language.Haskell.Exts.Pretty as HS
+import Language.Haskell.Exts.Syntax as HS
+import Language.Haskell.TH
+import Language.Haskell.TH.Ppr
+import Language.Haskell.TH.Syntax   as TH
 import System.Environment
 import System.IO
+import Text.PrettyPrint             (Doc, doubleQuotes, empty, text, vcat, ($$),
+                                     (<+>))
+import Text.Show.Pretty
 
-hack_incs = [ "-I." ]
-
--- pkg-config --cflags clutter-1.0
-clutter_incs =
- [ "-pthread"
- , "-I/usr/include/clutter-1.0"
- , "-I/usr/include/cogl"
- , "-I/usr/include/atk-1.0"
- , "-I/usr/include/cogl"
- , "-I/usr/include/libdrm"
- , "-I/usr/include/json-glib-1.0"
- , "-I/usr/include/gtk-3.0"
- , "-I/usr/include/gio-unix-2.0/"
- , "-I/usr/include/cairo"
- , "-I/usr/include/pango-1.0"
- , "-I/usr/include/harfbuzz"
- , "-I/usr/include/pango-1.0"
- , "-I/usr/include/gdk-pixbuf-2.0"
- , "-I/usr/include/libpng16"
- , "-I/usr/include/cairo"
- , "-I/usr/include/pixman-1"
- , "-I/usr/include/freetype2"
- , "-I/usr/include/libpng16"
- , "-I/usr/include/glib-2.0"
- , "-I/usr/lib/x86_64-linux-gnu/glib-2.0/include"
- ]
-
-
--- pkg-config --cflags cogl-pango-2.0-experimental
-cogl_pango2_incs =
- [ "-D COGL_ENABLE_EXPERIMENTAL_2_0_API"
- , "-pthread"
- , "-I/usr/include/cogl"
- , "-I/usr/include/cairo"
- , "-I/usr/include/pixman-1"
- , "-I/usr/include/freetype2"
- , "-I/usr/include/libpng16"
- , "-I/usr/include/gdk-pixbuf-2.0"
- , "-I/usr/include/libpng16"
- , "-I/usr/include/glib-2.0"
- , "-I/usr/lib/x86_64-linux-gnu/glib-2.0/include"
- , "-I/usr/include/libdrm"
- ]
-
-
--- pkg-config cogl-pango-1.0 --cflags
-cogl_pango_incs =
- [ "-pthread"
- , "-I/usr/include/cogl"
- , "-I/usr/include/cairo"
- , "-I/usr/include/pixman-1"
- , "-I/usr/include/freetype2"
- , "-I/usr/include/libpng16"
- , "-I/usr/include/gdk-pixbuf-2.0"
- , "-I/usr/include/libpng16"
- , "-I/usr/include/glib-2.0"
- , "-I/usr/lib/x86_64-linux-gnu/glib-2.0/include"
- , "-I/usr/include/libdrm" ]
-
--- pkg-config gtk+-3.0 --cflags
-gtk_incs =
- [ "-pthread"
- , "-I/usr/include/gtk-3.0"
- , "-I/usr/include/at-spi2-atk/2.0"
- , "-I/usr/include/at-spi-2.0"
- , "-I/usr/include/dbus-1.0"
- , "-I/usr/lib/x86_64-linux-gnu/dbus-1.0/include"
- , "-I/usr/include/gtk-3.0"
- , "-I/usr/include/gio-unix-2.0/"
- , "-I/usr/include/cairo"
- , "-I/usr/include/pango-1.0"
- , "-I/usr/include/harfbuzz"
- , "-I/usr/include/pango-1.0"
- , "-I/usr/include/atk-1.0"
- , "-I/usr/include/cairo"
- , "-I/usr/include/pixman-1"
- , "-I/usr/include/freetype2"
- , "-I/usr/include/libpng16"
- , "-I/usr/include/gdk-pixbuf-2.0"
- , "-I/usr/include/libpng16"
- , "-I/usr/include/glib-2.0"
- , "-I/usr/lib/x86_64-linux-gnu/glib-2.0/include"
- ]
-
--- pkg-config --cflags gobject-introspection-1.0
-gobj_incs =
- [ "-pthread"
- , "-I/usr/include/gobject-introspection-1.0"
- , "-I/usr/include/glib-2.0"
- , "-I/usr/lib/x86_64-linux-gnu/glib-2.0/include"
- ]
-
--- pkg-config --cflags libmutter-1
-mutter_incs =
- [ "-pthread"
- , "-I/usr/include/mutter"
- , "-I/usr/include/gtk-3.0"
- , "-I/usr/include/at-spi2-atk/2.0"
- , "-I/usr/include/at-spi-2.0"
- , "-I/usr/include/dbus-1.0"
- , "-I/usr/lib/x86_64-linux-gnu/dbus-1.0/include"
- , "-I/usr/include/gtk-3.0"
- , "-I/usr/include/gio-unix-2.0/"
- , "-I/usr/include/cairo"
- , "-I/usr/include/mutter/clutter-1"
- , "-I/usr/include/cairo"
- , "-I/usr/include/atk-1.0"
- , "-I/usr/include/pango-1.0"
- , "-I/usr/include/harfbuzz"
- , "-I/usr/include/pango-1.0"
- , "-I/usr/include/json-glib-1.0"
- , "-I/usr/include/mutter/cogl"
- , "-I/usr/include/cairo"
- , "-I/usr/include/pixman-1"
- , "-I/usr/include/freetype2"
- , "-I/usr/include/libpng16"
- , "-I/usr/include/gdk-pixbuf-2.0"
- , "-I/usr/include/libpng16"
- , "-I/usr/include/glib-2.0"
- , "-I/usr/lib/x86_64-linux-gnu/glib-2.0/include"
- , "-I/usr/include/libdrm"
- , "-I/usr/include/gsettings-desktop-schemas"
- ]
-
--- pkg-config --cflags gjs-1.0
-gjs_incs =
- [ "-pthread"
- , "-include"
- , "/usr/include/mozjs-52/js/RequiredDefines.h"
- , "-pthread"
- , "-I/usr/include/gobject-introspection-1.0"
- , "-I/usr/include/mozjs-52"
- , "-I/usr/include/gtk-3.0"
- , "-I/usr/include/at-spi2-atk/2.0"
- , "-I/usr/include/at-spi-2.0"
- , "-I/usr/include/dbus-1.0"
- , "-I/usr/lib/x86_64-linux-gnu/dbus-1.0/include"
- , "-I/usr/include/gtk-3.0"
- , "-I/usr/include/gio-unix-2.0/"
- , "-I/usr/include/cairo"
- , "-I/usr/include/pango-1.0"
- , "-I/usr/include/harfbuzz"
- , "-I/usr/include/pango-1.0"
- , "-I/usr/include/atk-1.0"
- , "-I/usr/include/cairo"
- , "-I/usr/include/pixman-1"
- , "-I/usr/include/freetype2"
- , "-I/usr/include/libpng16"
- , "-I/usr/include/gdk-pixbuf-2.0"
- , "-I/usr/include/libpng16"
- , "-I/usr/include/glib-2.0"
- , "-I/usr/lib/x86_64-linux-gnu/glib-2.0/include"
- , "-I/usr/include/gjs-1.0"
- ]
+-- | Pretty print the given tranlation unit, but replace declarations from header files with @#include@ directives.
+--
+-- The resulting file may not compile (because of missing @#define@ directives and similar things), but is very useful
+-- for testing, as otherwise the pretty printed file will be cluttered with declarations from system headers.
+prettyUsingInclude :: CTranslUnit -> Doc
+prettyUsingInclude (CTranslUnit edecls _) =
+  includeWarning headerFiles
+    $$
+  vcat (map (either includeHeader pretty) mappedDecls)
+  where
+    (headerFiles,mappedDecls) = foldr (addDecl . tagIncludedDecls) (Set.empty,[]) edecls
+    tagIncludedDecls edecl | maybe False isHeaderFile (fileOfNode edecl) = Left ((posFile . posOf) edecl)
+                           | otherwise = Right edecl
+    addDecl decl@(Left headerRef) (headerSet, ds)
+      | Set.member headerRef headerSet = (headerSet, ds)
+      | otherwise = (Set.insert headerRef headerSet, decl : ds)
+    addDecl decl (headerSet,ds) = (headerSet, decl : ds)
+    includeHeader hFile = text "#include" <+> doubleQuotes (text hFile)
+    isHeaderFile = (".h" `isSuffixOf`)
+    includeWarning hs | Set.null hs = empty
+                      | otherwise = text "/* Warning: The #include directives in this file aren't necessarily correct. */"
 
+specs :: CExternalDeclaration a -> [CDeclarationSpecifier a]
+specs (CFDefExt (CFunDef specs _ _ _ _)) = specs
+specs (CDeclExt (CDecl specs _ _))       = specs
+specs _                                  = []
 
+declrSym :: CDeclarator t -> Maybe Ident
+declrSym (CDeclr m _ _ _ _) = m
+
+sym :: CExternalDeclaration a -> [Maybe Ident]
+sym (CFDefExt (CFunDef specs m _ _ _)) = [ declrSym m ]
+sym (CDeclExt (CDecl specs ms _))      = ms >>= \(m,_,_) -> maybe [] (pure . declrSym) m
+sym _                                  = []
+
+isStatic :: CDeclarationSpecifier a -> Bool
+isStatic (CStorageSpec (CStatic _)) = True
+isStatic _                          = False
+
+capitalize :: String -> String
+capitalize xs = concatMap (cap . drop 1) gs
+    where
+        gs = groupBy (\a b -> b/='_') $ '_':xs
+        cap (c:cs) = toUpper c : cs
+
+transField :: CDeclaration t -> [(TH.Name, TH.Bang, TH.Type)]
+transField (CDecl [CTypeSpec (CTypeDef ctyp _)] vars _)
+    = do
+        let typname = mkName . capitalize . identToString $ ctyp
+        (var,Nothing,Nothing) <- vars
+        CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var
+        let fieldName = mkName $ identToString fident
+            ftyp = case ptrdeclr of
+                []               -> ConT typname
+                [CPtrDeclr [] _] -> AppT (ConT (mkName "Ptr")) (ConT typname)
+        [ (fieldName, Bang NoSourceUnpackedness NoSourceStrictness, ftyp) ]
+transField (CDecl [CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)] vars _)
+    | Just typname <- mkName . capitalize . identToString <$> mctyp
+    = do
+        (var,Nothing,Nothing) <- vars
+        CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var
+        let fieldName = mkName $ identToString fident
+            ftyp = case ptrdeclr of
+                []               -> ConT typname
+                [CPtrDeclr [] _] -> AppT (ConT (mkName "Ptr")) (ConT typname)
+        [ (fieldName, Bang NoSourceUnpackedness NoSourceStrictness, ftyp) ]
+
+
+transField _ = []
+
+transpile (CDeclExt (CDecl [ CTypeSpec (CSUType
+                                (CStruct CStructTag mbIdent (Just fields) [] _)
+                                _) ]
+                           []
+                            _) )
+    | Just struct_name <- capitalize . identToString <$> mbIdent
+    , let typ = mkName struct_name
+    = Just $ returnQ $ DataD [] typ [] Nothing [RecC typ fs] []
+        where fs = fields >>= transField
+
+transpile _ = Nothing
+
+
+isHeaderDecl :: CNode a => a -> Bool
+isHeaderDecl = maybe False (isSuffixOf ".h") . fileOfNode
+
+-- bar :: CExternalDeclaration NodeInfo -> ()
+-- bar (CDeclExt (CDecl xs [] (NodeInfo pos poslen name))) = ()
+
+data SymbolInformation c = SymbolInformation
+    { symbolLocal :: Bool
+    , symbolStatic :: Bool
+    , symbolSource :: c
+    }
+ deriving (Eq,Ord,Show)
+
+symbolInformation = SymbolInformation
+    { symbolLocal = False
+    , symbolStatic = False
+    , symbolSource = mempty
+    }
+
+data Transpile c = Transpile
+    { syms :: Map String (SymbolInformation c)
+    }
+
+initTranspile = Transpile
+    { syms = Map.empty
+    }
+
+-- grokSymbol :: CExternalDeclaration a -> String -> Maybe SymbolInformation -> Maybe SymbolInformation
+grokSymbol d k msi =
+    let si = fromMaybe symbolInformation msi
+    in Just $ si
+    { symbolLocal = symbolLocal si || not (isHeaderDecl d)
+    , symbolStatic = symbolStatic si || any isStatic (specs d)
+    , symbolSource = d : symbolSource si
+    }
+
+-- update :: CExternalDeclaration a -> Transpile -> Transpile
+update d transpile = transpile
+    { syms = foldr (\k m -> Map.alter (grokSymbol d k) k m) (syms transpile)
+                $ map (maybe "" identToString) $ sym d
+    }
+
+data FunctionSignature t = FunctionSignature
+    { funReturnType :: t
+    , funArgTypes :: [t]
+    }
+
+hsMkName :: String -> HS.QName ()
+hsMkName str = HS.UnQual () (foo () str)
+ where
+    foo = HS.Ident -- alternative: HS.Symbol
+
+hsTypeSpec :: CDeclarationSpecifier t -> [String]
+hsTypeSpec (CTypeSpec (CTypeDef ctyp _))                                   = [capitalize . identToString $ ctyp]
+hsTypeSpec (CTypeSpec (CBoolType _))                                       = ["Bool"]
+hsTypeSpec (CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)) = maybeToList $ fmap (capitalize . identToString) mctyp
+hsTypeSpec _                                                               = []
+
+-- hsTransField :: [CDeclarationSpecifier t3] -> [(Maybe (CDeclarator t2), Maybe t1, Maybe t)] -> [HS.Decl ()]
+hsTransField ctyps vars
+    = do
+        typname <- hsMkName <$> (hsTypeSpec =<< ctyps)
+        (var,Nothing,Nothing) <- vars
+        CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var
+        let btyp = HS.TyCon () typname
+            grok bs b = case bs of
+                []                               -> b
+                (CPtrDeclr [] _:cs)              -> HS.TyApp () (HS.TyCon () (hsMkName "Ptr")) (grok cs b)
+                [CFunDeclr (Right (args,flg)) attrs _] -> let (as,ts) = unzip $ concatMap (\(CDecl rs as _) -> hsTransField rs as) args
+                                                          in foldr (HS.TyFun ()) b ts
+                _                                -> HS.TyCon () (hsMkName $ show $ map (fmap (const ())) ptrdeclr)
+            ftyp = grok ptrdeclr btyp
+            fieldName = identToString fident
+        [ ( fieldName, ftyp ) ]
+{-
+transField (CDecl [CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)] vars _)
+    | Just typname <- mkName . capitalize . identToString <$> mctyp
+    = do
+        (var,Nothing,Nothing) <- vars
+        CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var
+        let fieldName = mkName $ identToString fident
+            ftyp = case ptrdeclr of
+                []               -> ConT typname
+                [CPtrDeclr [] _] -> AppT (ConT (mkName "Ptr")) (ConT typname)
+        [ (fieldName, Bang NoSourceUnpackedness NoSourceStrictness, ftyp) ]
+hsTransField _ _ = []
+-}
+
+hsTransFieldExt rs as = concatMap (\(fieldName,ftyp)-> [ HS.TypeSig () [ HS.Ident () fieldName ] ftyp ])
+                                        $ hsTransField rs as
+
+sig (CDeclExt (CDecl rs as _))              = hsTransFieldExt rs as
+sig (CFDefExt (CFunDef rs cdeclr [] bdy _)) = hsTransFieldExt rs [(Just cdeclr, Nothing, Nothing)]
+
+body0 (CFDefExt (CFunDef rs cdeclr [] bdy _)) = Just bdy
+body0 _                                       = Nothing
+
+body (CFDefExt (CFunDef rs cdeclr [] (CCompound [] bdy _) _)) = bdy
+body _                                                        = []
+
+data SideEffect = PointerWrite | FunctionCall
+
+calls :: Data t => t -> [CExpression NodeInfo]
+calls = everything (++) (mkQ [] (\case { cc@C.CCall {} -> [cc] ; _ -> [] }))
+
+mutations1 e@(CAssign {})            = [e]
+mutations1 e@(CUnary CPreIncOp _ _)  = [e]
+mutations1 e@(CUnary CPreDecOp _ _)  = [e]
+mutations1 e@(CUnary CPostIncOp _ _) = [e]
+mutations1 e@(CUnary CPostDecOp _ _) = [e]
+mutations1 _                         = []
+
+mutations :: Data t => t -> [CExpression NodeInfo]
+mutations = everything (++) (mkQ [] mutations1)
+
+
+-- gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b) -> (forall g. g -> c g) -> a -> c a
+--
+-- gfoldl app con
+--
+-- does is to turn such a value into
+--
+-- con C `app` x_1 `app` x_2 ... `app` x_n
+
+
+commented :: String -> String
+commented s = unlines $ map ("-- " ++) (lines s)
+
+c2haskell cs (CTranslUnit edecls _) = do
+    let db = foldr update initTranspile edecls
+        es = Map.filter (\d -> symbolLocal d && not (symbolStatic d)) (syms db)
+    forM_ (Map.toList es) $ \(k,si) -> do
+        putStrLn ""
+        putStrLn (commented k)
+        forM_ (symbolSource si) $ \d -> do
+            putStr $ commented (ppShow (fmap (const ()) d))
+            putStr $ commented (show $ pretty d)
+            mapM_ (putStrLn . HS.prettyPrint) (sig d)
+            {-
+            forM_  (body d) $ \stmt -> do
+                putStr $ commented (take 130 $ show (fmap (const ()) stmt))
+                putStr $ commented (ppShow (fmap (const ()) stmt))
+                putStrLn $ commented . show . pretty $ stmt
+            putStr $ commented "calls"
+            mapM_ (putStr . commented . show . pretty) (calls (body d))
+            putStrLn "--"
+            putStr $ commented "mutations"
+            mapM_ (putStr . commented . show . pretty) (mutations (body d))
+            -}
+
+readComments fname = parseComments 1 1 <$> readFile fname
+
+findCloser !1 (l,c,b) ('*':'/':_)  = (l,c+2,b+2)
+findCloser !d (l,c,b) ('*':'/':xs) = findCloser (d - 1) (l,c+2,b+2) xs
+findCloser !d (l,c,b) ('/':'*':xs) = findCloser (d + 1) (l,c+2,b+2) xs
+findCloser !d (l,c,b) ('\n':xs)    = findCloser d (l+1,1,b+1) xs
+findCloser !d (l,c,b) (_:xs)       = findCloser d (l,c+1,b+1) xs
+findCloser !d (l,c,b) []           = (l,c,b)
+
+mkComment lin no str = (lin,no,str)
+
+parseComments !lin !col = \case
+    ('/':'*':cs) -> let (lcnt,col',bcnt) = findCloser 1 (0,col,0) cs
+                        (xs,cs') = splitAt bcnt cs
+                    in mkComment lin col xs : parseComments (lin + lcnt) col' cs'
+    ('/':'/':cs) -> let (comment,ds) = break (=='\n') cs
+                    in mkComment lin col comment : parseComments (lin + 1) 1 cs
+    ('\n' : cs) -> parseComments (lin+1) 1       cs
+    (  x  : cs) -> parseComments lin     (col+1) cs
+    []          -> []
+
+sanitizeArgs :: [String] -> [String]
+sanitizeArgs (('-':'M':_):args) = sanitizeArgs args
+sanitizeArgs (('-':'O':_):args) = sanitizeArgs args
+sanitizeArgs (('-':'c':_):args) = sanitizeArgs args
+sanitizeArgs ("-o":args)        = sanitizeArgs $ drop 1 args
+sanitizeArgs (arg:args)         = arg : sanitizeArgs args
+sanitizeArgs []                 = []
+
+main :: IO ()
 main = do
     args <- getArgs
     let fname = last args
-        opts = ["-DGETTEXT_PACKAGE=c2haskell"] ++ init args
-        incs = "-I." : gjs_incs ++ gobj_incs ++ mutter_incs ++ clutter_incs ++ cogl_pango2_incs ++ gtk_incs
-    r <- parseCFile (newGCC "gcc") Nothing (incs ++ opts) fname
-    print (fmap prettyUsingInclude r)
+        opts = init args
+    r <- parseCFile (newGCC "gcc") Nothing (sanitizeArgs opts) fname
+    -- print (fmap prettyUsingInclude r)
+    cs <- readComments fname
+    either print (c2haskell cs) r