Binary ops and global pointer refs.

1 files changed, 117 insertions, 15 deletions

diff --git a/monkeypatch.hs b/monkeypatch.hs
index bc55425..352a0f5 100644
--- a/monkeypatch.hs
+++ b/monkeypatch.hs
@@ -7,9 +7,12 @@
 {-# LANGUAGE QuasiQuotes              #-}
 {-# LANGUAGE TemplateHaskell          #-}
 {-# LANGUAGE TupleSections            #-}
+{-# LANGUAGE ScopedTypeVariables      #-}
 module Main where
 
+import Debug.Trace
 import Control.Arrow (left,first,second)
+import Data.Bool
 import Data.Either
 import Data.Generics.Aliases
 import Data.Generics.Schemes
@@ -52,8 +55,10 @@ import Text.Show.Pretty
 import Sweeten
 import GrepNested
 
+{-
 trace :: p -> a -> a
 trace _ = id
+-}
 
 -- | Pretty print the given tranlation unit, but replace declarations from header files with @#include@ directives.
 --
@@ -197,16 +202,105 @@ varmap vs = Map.fromList $ map (,()) vs
 
 -}
 
+
+renameIntros :: forall v st. (Typeable st, Data st) =>
+                [Computation (HS.Exp st)]
+                -> Computation (HS.Exp st)
+                -> Map String v
+                -> ([Computation (HS.Exp st)], Computation (HS.Exp st))
+renameIntros bs cb vs = (bs',cb')
+ where
+    (rs,bs') = unzip $ map go bs
+
+    cb' = foldr rename2 cb $ concat rs
+
+    rename2 (x,v) c =
+        let subst p@(Var la (UnQual lc (HS.Ident lb s)))
+                | s==x  = Var (la::st) (UnQual lc (HS.Ident lb v))
+            subst p = p
+        in c { comp = everywhere (mkT subst) (comp c) }
+
+    go c =
+        let xs = Map.keys (compIntro c)
+        in foldr rename1 ([],c) xs
+
+    rename1 x (rs,c) =
+        let v = uniqIdentifier x vs
+            subst p@(PVar la (HS.Ident lb s))
+                | s==x  = PVar (la::st) (HS.Ident lb v)
+            subst p = p
+        in if x/=v then (,) ((x,v):rs) c { compIntro = Map.insert v () $ Map.delete x (compIntro c)
+                                         , comp = everywhere (mkT subst) (comp c)
+                                         }
+                   else (rs,c)
+
+transpileBinOp :: CBinaryOp -> [Char]
+transpileBinOp = \case
+    CMulOp -> "*"
+    CDivOp -> "/"
+    CRmdOp -> "rem"
+    CAddOp -> "+"
+    CSubOp -> "-"
+    CShlOp -> "shiftL"
+    CShrOp -> "shiftR"
+    CLeOp  -> "<"
+    CGrOp  -> ">"
+    CLeqOp -> "<="
+    CGeqOp -> ">="
+    CEqOp  -> "=="
+    CNeqOp -> "/="
+    CAndOp -> ".&."
+    CXorOp -> "xor"
+    COrOp  -> ".|."
+    CLndOp -> "and"
+    CLorOp -> "or"
+
+-- This function decides whether to treat an identifier as a constant or as a
+-- pointer that must be peeked.
+isGlobalRef :: FunctionEnvironment -> String -> Bool
+isGlobalRef fe sym = fromMaybe False $ do
+    SymbolInformation{symbolSource = xs} <- Map.lookup sym (fnExternals fe)
+    forM_ xs $ \x -> do
+        -- Pattern fail for functions and pointers.
+        forM_ (sigf (\_ ds -> ds) x) $ \d -> do
+            CDeclr _ xs _ _ _ <- Just d
+            let func = filter (\case
+                        CFunDeclr _ _ _ -> True
+                        _               -> False) xs
+            guard $ null func -- Functions are not pointerized.
+            -- trace (sym ++ ": " ++ show xs) $ return ()
+            -- ring: [CPtrDeclr [] (NodeInfo ("fetchers/about.c": line 64) (("fetchers/about.c": line 64),4) (Name {nameId = 14030}))]
+            return ()
+    return True
+
 -- Returns a list of statements bringing variables into scope and an
 -- expression.
 grokExpression :: FunctionEnvironment
                   -> CExpression a
                   -> Maybe ([Computation (HS.Exp ())], Computation (HS.Exp ()))
-grokExpression fe (CVar cv _) = Just $ (,) [] $ Computation
-    { compFree  = Map.singleton (identToString cv) ()
-    , compIntro = Map.empty
-    , comp      = hsvar (identToString cv)
-    }
+grokExpression fe (CVar cv _) =
+    let v = identToString cv
+    in Just $
+        if isGlobalRef fe v
+            then let k = uniqIdentifier "go" (varmap [v,hv])
+                     s = Computation
+                            { compFree  = Map.singleton v ()
+                            , compIntro = Map.singleton hv ()
+                            , comp      = Lambda () [hspvar k]
+                                            $ infixOp (App () (hsvar "peek") (hsvar v)) ">>="
+                                            $ Lambda () [hspvar hv] (hsvar k)
+                            }
+                     hv = "v" ++ v
+                 in (,) [s] Computation
+                            { compFree  = Map.singleton hv ()
+                            , compIntro = Map.empty
+                            , comp      = hsvar hv
+                            }
+            else (,) [] $ Computation
+                { compFree  = Map.singleton (identToString cv) ()
+                , compIntro = Map.empty
+                , comp      = hsvar v
+                }
 grokExpression fe (CConst (CIntConst n _)) = Just $ (,) [] $ Computation
     { compFree  = Map.empty
     , compIntro = Map.empty
@@ -217,14 +311,20 @@ grokExpression fe (CConst (CStrConst s _)) = Just $ (,) [] $ Computation
     , compIntro = Map.empty
     , comp      = Lit () (HS.String () (getCString s) (getCString s))
     }
-grokExpression fe (CBinary CNeqOp a b _) = do
+grokExpression fe (CBinary op a b _) = do
     (as,ca) <- grokExpression fe a
-    (bs,cb) <- grokExpression fe b
-    let ss = as ++ bs -- TODO: resolve variable name conflicts
+    (bs0,cb0) <- grokExpression fe b
+    let (bs,cb) = renameIntros bs0 cb0 (foldr Map.union Map.empty $ map compIntro as)
+        ss = as ++ bs
+        hop = transpileBinOp op
+        infx | isLower (head hop) = infixFn
+             | otherwise          = infixOp
+    -- trace ("intros("++hop++"): "++show (foldr Map.union Map.empty $ map compIntro as)) $ return ()
+    -- TODO: Short-circuit boolean evaluation side-effects.
     return $ (,) ss $ Computation
         { compFree  = compFree ca `Map.union` compFree cb
         , compIntro = Map.empty
-        , comp      = infixOp (comp ca) "/=" (comp cb)
+        , comp      = infx (comp ca) hop (comp cb)
         }
 grokExpression fe (CUnary CAdrOp (CVar cv0 _) _) = do
     let cv = identToString cv0
@@ -573,6 +673,8 @@ insertComment c stmts = everywhere (mkT go) stmts
 mixComments :: [StyledComment] -> [CCompoundBlockItem NodeInfo] -> [CCompoundBlockItem NodeInfo]
 mixComments cs stmts = foldr insertComment stmts cs
 
+applyDoSyntax' :: Data l =>
+                  C2HaskellOptions -> HS.Exp l -> HS.Exp l
 applyDoSyntax' C2HaskellOptions{oSuppressDo=True} x = x
 applyDoSyntax' _                                  x = applyDoSyntax x
 
@@ -763,7 +865,7 @@ hsTypeSpec (CTypeSpec (CIntType  _))                                       = [ R
 hsTypeSpec (CTypeSpec (CCharType _))                                       = [ Right "Char"]
 hsTypeSpec (CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)) = maybeToList $ fmap Left mctyp
 
-hsTypeSpec (CTypeSpec unhandled) = trace ("hsTypeSpec unhandled: "++ show (const () <$> unhandled)) $ []
+hsTypeSpec (CTypeSpec unhandled) = [] -- trace ("hsTypeSpec unhandled: "++ show (const () <$> unhandled)) $ []
 hsTypeSpec _ = []
 
 
@@ -786,15 +888,15 @@ hsTransField ctyps vars
         (mcname,typname) <- second hsMkName . either ((\s -> (Just s,capitalize s)) . identToString)
                                                      (Nothing,)
                                                      <$> (hsTypeSpec =<< ctyps)
-        trace ("typname="++show typname) $ return ()
+        -- trace ("typname="++show typname) $ return ()
         -- (var,Nothing,Nothing) <- vars
         var <- vars
-        trace ("var="++show var) $ return ()
+        -- trace ("var="++show var) $ return ()
         -- CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var
         let CDeclr mfident ptrdeclr Nothing ignored_attrs _ = var -- TODO: Look into: Irrefutable pattern failed (ctox/toxcore/DHT.c)
         -- let CDeclr mfident ptrdeclr _ _ _ = var
-        trace ("fident="++show mfident) $ return ()
-        trace ("ptrdeclr="++show ptrdeclr) $ return ()
+        -- trace ("fident="++show mfident) $ return ()
+        -- trace ("ptrdeclr="++show ptrdeclr) $ return ()
         let btyp = HS.TyCon () typname
             grok :: Show a => [CDerivedDeclarator a] -> HS.Type () -> HS.Type ()
             grok bs b = case bs of
@@ -1306,7 +1408,7 @@ getArgList_ (CFDefExt (CFunDef xs ys zs c d)) = getArgList1 ys
 getArgList_ (CDeclExt (CDecl xs ys pos))      = getArgList2 ys
 
 getArgList :: CExternalDeclaration a -> [CDerivedDeclarator a]
-getArgList x = let v=getArgList_ x in trace ("getArgList ("++show (u x)++") = "++show (fmap u v)) v
+getArgList x = let v=getArgList_ x in {- trace ("getArgList ("++show (u x)++") = "++show (fmap u v)) -} v
  where
     u :: Functor f => f a -> f ()
     u = fmap (const ())