From d5fd902d4e95c8e78cc658147499883d21218225 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sat, 23 Mar 2019 20:49:53 -0400 Subject: Distinguish formal lambda type. --- monkeypatch.hs | 80 +++++++++++++++++++++++++++++++--------------------------- 1 file changed, 43 insertions(+), 37 deletions(-) diff --git a/monkeypatch.hs b/monkeypatch.hs index e58cc2e..0b115e3 100644 --- a/monkeypatch.hs +++ b/monkeypatch.hs @@ -176,12 +176,17 @@ infixOp x op y = InfixApp () x (QVarOp () (UnQual () (Symbol () op))) y infixFn :: HS.Exp () -> String -> HS.Exp () -> HS.Exp () infixFn x fn y = InfixApp () x (QVarOp () (UnQual () (HS.Ident () fn))) y +data FormalLambda = FormalLambda { formGo :: String + , formExp :: HS.Exp () + } +informalize :: FormalLambda -> HS.Exp () +informalize (FormalLambda k x) = Lambda () [hspvar k] x -applyComputation :: Computation (HS.Exp ()) -> Computation (HS.Exp ()) -> Computation (HS.Exp ()) -applyComputation a@Computation{ comp = (Lambda () [PVar () govar] exp) } b = - let matchgo (Var () (UnQual () v)) = v==govar - matchgo _ = False +applyComputation :: Computation FormalLambda -> Computation (HS.Exp ()) -> Computation (HS.Exp ()) +applyComputation a@Computation{ comp = FormalLambda govar exp } b = + let matchgo (Var () (UnQual () (HS.Ident () v))) = v==govar + matchgo _ = False in case listify matchgo exp of (_:_:_) -> error "TODO: Multiple go-refs; make let binding." _ -> Computation @@ -191,7 +196,6 @@ applyComputation a@Computation{ comp = (Lambda () [PVar () govar] exp) } b = | otherwise = x in everywhere (mkT subst) exp } -applyComputation a b = a varmap :: [String] -> Map String () varmap vs = Map.fromList $ map (,()) vs @@ -203,11 +207,11 @@ varmap vs = Map.fromList $ map (,()) vs -} -renameIntros :: forall v st. (Typeable st, Data st) => - [Computation (HS.Exp st)] +renameIntros :: forall v st a. (Typeable st, Data st) => + [Computation FormalLambda] -> Computation (HS.Exp st) -> Map String v - -> ([Computation (HS.Exp st)], Computation (HS.Exp st)) + -> ([Computation FormalLambda], Computation (HS.Exp st)) renameIntros bs cb vs = (bs',cb') where (rs,bs') = unzip $ map go bs @@ -230,7 +234,7 @@ renameIntros bs cb vs = (bs',cb') | 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) + , comp = (comp c) { formExp = everywhere (mkT subst) (formExp $ comp c) } } else (rs,c) @@ -277,7 +281,7 @@ isGlobalRef fe sym = fromMaybe False $ do -- expression. grokExpression :: FunctionEnvironment -> CExpression a - -> Maybe ([Computation (HS.Exp ())], Computation (HS.Exp ())) + -> Maybe ([Computation FormalLambda], Computation (HS.Exp ())) grokExpression fe (CVar cv _) = let v = identToString cv in Just $ @@ -286,7 +290,7 @@ grokExpression fe (CVar cv _) = s = Computation { compFree = Map.singleton v () , compIntro = Map.singleton hv () - , comp = Lambda () [hspvar k] + , comp = FormalLambda k $ infixOp (App () (hsvar "peek") (hsvar v)) ">>=" $ Lambda () [hspvar hv] (hsvar k) } @@ -333,7 +337,7 @@ grokExpression fe (CUnary CAdrOp (CVar cv0 _) _) = do ss = pure Computation { compFree = Map.singleton cv () , compIntro = Map.singleton hv () - , comp = Lambda () [hspvar k] + , comp = FormalLambda k $ infixFn (hsvar cv) "withPointer" (Lambda () [hspvar hv] (hsvar k)) @@ -369,11 +373,13 @@ grokExpression fe (CComma exps _) = do gs <- mapM (grokExpression fe) exps let gs2 = map (\(ss,x) -> foldr applyComputation (App () (hsvar "return") <$> x) ss) gs parn e = Paren () e - ps = map (\x -> let k = uniqIdentifier "go" (compFree x) in fmap (\xx -> Lambda () [hspvar k] (infixOp (parn xx) ">>" (hsvar k))) x) (init gs2) + ps = map (\x -> let k = uniqIdentifier "go" (compFree x) + in fmap (\xx -> FormalLambda k (infixOp (parn xx) ">>" (hsvar k))) x) + (init gs2) s = foldr applyComputation (last gs2) ps hv = "u" k = uniqIdentifier "go" (compFree s) - s' = fmap (\x -> Lambda () [hspvar k] (infixOp (parn x) ">>=" (Lambda () [hspvar hv] (hsvar k)))) s + s' = fmap (\x -> FormalLambda k (infixOp (parn x) ">>=" (Lambda () [hspvar hv] (hsvar k)))) s -- TODO: It would be cleaner if I could return only a statement and not an expression. return ([s'],Computation (Map.singleton hv ()) Map.empty (hsvar hv)) grokExpression fe (C.CCall (CVar fn _) exps _) = do @@ -386,7 +392,7 @@ grokExpression fe (C.CCall (CVar fn _) exps _) = do s = Computation { compFree = frees , compIntro = Map.singleton hv () - , comp = Lambda () [hspvar k] + , comp = FormalLambda k $ infixOp cll ">>=" $ Lambda () [hspvar hv] (hsvar k) } @@ -408,7 +414,7 @@ grokExpression fe (CStatExpr (CCompound idents xs _) _) = do s = Computation { compFree = compFree s1 , compIntro = Map.singleton hv () - , comp = Lambda () [hspvar k] + , comp = FormalLambda k $ infixOp (comp s1) ">>=" $ Lambda () [hspvar hv] (hsvar k) } @@ -423,7 +429,7 @@ grokExpression fe (CAssign CAssignOp cvar expr _) = do let k = uniqIdentifier "go" (Map.insert v () $ foldr (\s m -> compFree s `Map.union` compIntro s `Map.union` m) Map.empty ss) s = x { compIntro = Map.singleton v () - , comp = Lambda () [hspvar k] + , comp = FormalLambda k $ infixOp (App () (hsvar "return") (comp x)) ">>=" $ Lambda () [hspvar v] (hsvar k) } @@ -439,7 +445,7 @@ grokInitialization :: Foldable t1 => FunctionEnvironment -> t1 (CDeclarationSpecifier t2) -> (Maybe (CDeclarator a1), CInitializer a2) - -> Maybe (Computation (HS.Exp ())) + -> Maybe (Computation FormalLambda) grokInitialization fe _ (Just (CDeclr (Just cv0) _ _ _ _),CInitExpr exp _) = do let v = identToString cv0 (xs,x) <- grokExpression fe exp @@ -448,7 +454,7 @@ grokInitialization fe _ (Just (CDeclr (Just cv0) _ _ _ _),CInitExpr exp _) = do fmap (\exp -> infixOp exp ">>=" $ Lambda () [hspvar v] (hsvar k)) hsexp k = uniqIdentifier "go" (compFree ret) - return $ fmap (\exp -> Lambda () [hspvar k] exp) ret + return $ fmap (FormalLambda k) ret grokInitialization fe ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = do let v = identToString cv0 -- let k = uniqIdentifier "go" (varmap [v]) @@ -471,24 +477,24 @@ grokInitialization fe ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = d fieldinit = comp x fieldlbl = identToString m return x - { comp = Lambda () [hspvar k1] + { comp = FormalLambda k1 $ infixOp (App () (App () (App () (hsvar "set") (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) (hsvar v)) fieldinit) ">>" (hsvar k1) } - return $ fmap (\exp -> Lambda () [hspvar k2] exp) ret + return $ fmap (FormalLambda k2) ret let newstruct = Computation { compFree = Map.empty -- todo , compIntro = Map.singleton v () - , comp = Lambda () [hspvar k] + , comp = FormalLambda k $ infixOp (App () (hsvar "newStruct") (TypeApp () (TyCon () (UnQual () hident)))) ">>=" $ Lambda () [hspvar v] (hsvar k) } k = uniqIdentifier "go" Map.empty -- (compFree ret) TODO ret = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) $ newstruct : assigns - return $ fmap (\exp -> Lambda () [hspvar k] exp) ret + return $ fmap (FormalLambda k) ret _ -> Nothing grokInitialization _ _ _ = Nothing @@ -502,14 +508,14 @@ promote fe y@(Lit () (Int () n _)) | (n==0 || n==1) && hasBool (fe Map.! "") = 1 -> "True" promote _ y = y -grokStatement :: FunctionEnvironment -> CCompoundBlockItem a -> Maybe (Computation (HS.Exp ())) +grokStatement :: FunctionEnvironment -> CCompoundBlockItem a -> Maybe (Computation FormalLambda) grokStatement fe (CBlockStmt (CReturn (Just exp) _)) = do (xs,x) <- grokExpression fe exp let k = uniqIdentifier "go" (compFree x `Map.union` compIntro x) x' = fmap (\y -> App () (hsvar "return") $ promote (fnArgs fe) y) x - return $ fmap (\y -> Lambda () [hspvar k] y) $ foldr applyComputation x' xs + return $ fmap (\y -> FormalLambda k y) $ foldr applyComputation x' xs grokStatement fe (CBlockStmt (CReturn Nothing _)) = - Just $ Computation Map.empty Map.empty $ Lambda () [hspvar "go"] retUnit + Just $ Computation Map.empty Map.empty $ FormalLambda "go" retUnit grokStatement fe (CBlockStmt (CIf exp thn els _)) = do (xs,x) <- grokExpression fe exp let mkif0 = If () (comp x) @@ -530,7 +536,7 @@ grokStatement fe (CBlockStmt (CIf exp thn els _)) = do ss <- sequence $ map (grokStatement fe) stmts let s = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) ss k = uniqIdentifier "go" (Map.union (compFree x) (compFree s)) - return $ fmap (Lambda () [hspvar k]) $ flip (foldr applyComputation) xs Computation + return $ fmap (FormalLambda k) $ flip (foldr applyComputation) xs Computation { compFree = compFree x `Map.union` compFree s , compIntro = compIntro s , comp = mkif (comp s) (hsvar k) @@ -542,7 +548,7 @@ grokStatement fe (CBlockStmt (CExpr (Just (C.CCall (CVar (C.Ident "__assert_fail _ -> Nothing let k = uniqIdentifier "go" (compFree x `Map.union` compIntro x) x' = fmap (\y -> App () (hsvar "error") y) x - return $ fmap (\y -> Lambda () [hspvar k] y) x' + return $ fmap (FormalLambda k) x' grokStatement fe (CBlockStmt (CExpr (Just (CAssign CAssignOp (CMember cvar fld isptr _) expr _)) _)) = do @@ -558,7 +564,7 @@ grokStatement fe (CBlockStmt (CExpr (Just (hsvar v)) fieldinit) ">>" (hsvar k1) } - return $ fmap (\y -> Lambda () [hspvar k1] y) $ foldr applyComputation x' xs + return $ fmap (FormalLambda k1) $ foldr applyComputation x' xs grokStatement fe (CBlockStmt (CExpr (Just (C.CCall cvarfun exps _)) _)) = do fn <- cvarName cvarfun @@ -572,7 +578,7 @@ grokStatement fe (CBlockStmt (CExpr (Just , compIntro = Map.empty , comp = infixOp cll ">>" (hsvar k) } - return $ fmap (Lambda () [hspvar k]) x + return $ fmap (FormalLambda k) x grokStatement fe (CBlockStmt (CExpr (Just (CAssign CAssignOp cvarnew (C.CCall cvarfun [] _) _)) _)) = do @@ -582,7 +588,7 @@ grokStatement fe (CBlockStmt (CExpr (Just return Computation { compFree = Map.singleton fn () , compIntro = Map.singleton v () - , comp = Lambda () [hspvar k] + , comp = FormalLambda k $ infixOp (hsvar fn) ">>=" $ Lambda () [hspvar v] (hsvar k) } @@ -593,7 +599,7 @@ grokStatement fe (CBlockStmt (CExpr (Just (CUnary CPostIncOp (CMember (CVar cv0 return Computation { compFree = varmap [v] , compIntro = Map.empty - , comp = Lambda () [hspvar k1] + , comp = FormalLambda k1 $ infixOp (App () (App () (App () (hsvar "modify") (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) @@ -607,14 +613,14 @@ grokStatement fe (CBlockStmt (CExpr (Just expr) _)) = do (ss,x) <- grokExpression fe expr let k = uniqIdentifier "go" $ foldr Map.union Map.empty $ map compFree ss ++ map compIntro ss g = Computation Map.empty Map.empty (hsvar k) - return $ fmap (Lambda () [hspvar k]) $ foldr applyComputation g ss + return $ fmap (FormalLambda k) $ foldr applyComputation g ss -} grokStatement fe (CBlockStmt (CExpr mexpr _)) = do (ss,pre) <- maybe (Just $ (,) [] $ Computation Map.empty Map.empty id) (fmap (second (fmap (\e -> infixFn e "seq"))) . grokExpression fe) mexpr let k = uniqIdentifier "go" (compFree s) s = foldr applyComputation (fmap ($ hsvar k) pre) ss - return $ fmap (Lambda () [hspvar k]) s + return $ fmap (FormalLambda k) s grokStatement fe (CBlockDecl (CDecl (t:ts) (v:vs) _)) = do -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CDeclr i _ initial _ _) -> initial) (v:vs) of -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CInitList xs _) -> Just xs) (v:vs) of @@ -623,11 +629,11 @@ grokStatement fe (CBlockDecl (CDecl (t:ts) (v:vs) _)) = do return Computation { compFree = Map.empty , compIntro = Map.empty - , comp = Lambda () [hspvar "go"] $ hsvar "go" + , comp = FormalLambda "go" $ hsvar "go" } initials -> do gs <- mapM (grokInitialization fe $ t:ts) initials - return $ fmap (\exp -> Lambda () [hspvar "go"] exp) + return $ fmap (FormalLambda "go") $ foldr applyComputation (Computation Map.empty Map.empty (hsvar "go")) gs grokStatement fe _ = Nothing @@ -772,7 +778,7 @@ transpile o fname incs (CTranslUnit edecls _) = do case grokStatement fe d of Just hd -> do putStrLn $ "fr: " ++ intercalate " " (Map.keys (compFree hd)) - putStrLn $ "HS: " ++ HS.prettyPrint (comp hd) + putStrLn $ "HS: " ++ HS.prettyPrint (informalize $ comp hd) Nothing -> putStrLn $ "??: " ++ ppShow (cleanTree d) putStrLn "" -- cgit v1.2.3