From 331690db265faaa8cb8b350d029c0fd6db88083a Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Wed, 27 Mar 2019 13:42:37 -0400 Subject: WIP: do-while. --- Unique.hs | 40 ++++++++++++++++++++++++++++ monkeypatch.cabal | 3 ++- monkeypatch.hs | 79 +++++++++++++++++++++++++++++++++++-------------------- 3 files changed, 93 insertions(+), 29 deletions(-) create mode 100644 Unique.hs diff --git a/Unique.hs b/Unique.hs new file mode 100644 index 0000000..13ae7cf --- /dev/null +++ b/Unique.hs @@ -0,0 +1,40 @@ +module Unique + ( UniqueFactory + , Unique + , uniqueSymbol + , substituteUnique + , multipleOccurances + ) where + +import Data.Generics.Aliases +import Data.Generics.Schemes +import Language.Haskell.Exts.Syntax + +newtype UniqueFactory = UniqueFactory Integer + +newtype Unique = Unique Integer + deriving (Eq,Ord) + +freshUniques :: UniqueFactory +freshUniques = UniqueFactory 0 + +genUnique :: UniqueFactory -> (Unique,UniqueFactory) +genUnique (UniqueFactory c) = (Unique c, UniqueFactory (succ c)) + +uniqueSymbol :: Unique -> Exp () +uniqueSymbol (Unique i) = Var () (UnQual () (Ident () (showSym i))) + +showSym :: Integer -> String +showSym i = " u" ++ show i + +substituteUnique :: Unique -> Exp () -> Exp () -> Exp () +substituteUnique u inner outer = everywhere (mkT $ subst inner) outer + where + subst x t | t == uniqueSymbol u = x + | otherwise = t + + +multipleOccurances :: Unique -> Exp () -> Bool +multipleOccurances u x = case listify (== uniqueSymbol u) x of + (x:y:ys) -> True + _ -> False diff --git a/monkeypatch.cabal b/monkeypatch.cabal index 2b06032..281320f 100644 --- a/monkeypatch.cabal +++ b/monkeypatch.cabal @@ -52,7 +52,7 @@ extra-source-files: CHANGELOG.md executable monkeypatch main-is: monkeypatch.hs - other-modules: GrepNested, Sweeten + other-modules: GrepNested, Sweeten, Unique -- other-extensions: build-depends: base >=4.10.1.0 && <=4.12 , containers ^>=0.5.10.2 @@ -65,5 +65,6 @@ executable monkeypatch , pretty-show , process , directory + , transformers -- hs-source-dirs: default-language: Haskell2010 diff --git a/monkeypatch.hs b/monkeypatch.hs index b3bbe2d..3b93e5b 100644 --- a/monkeypatch.hs +++ b/monkeypatch.hs @@ -11,7 +11,9 @@ module Main where import Debug.Trace -import Control.Arrow (left,first,second) + +import Control.Arrow (first, left, second) +import Control.Monad.Trans.State.Lazy import Data.Bool import Data.Either import Data.Generics.Aliases @@ -21,39 +23,40 @@ import Control.Monad import qualified Data.ByteString.Char8 as B import Data.Char import Data.Data -import Data.List import qualified Data.IntMap as IntMap ;import Data.IntMap (IntMap) -import qualified Data.Map as Map - ;import Data.Map (Map) +import Data.List +import qualified Data.Map as Map + ;import Data.Map (Map) import Data.Maybe import Data.Ord -import qualified Data.Set as Set - ;import Data.Set (Set) -import Language.C.Data.Ident as C -import Language.C.Data.Node as C -import Language.C as C hiding (prettyUsingInclude) -import qualified Language.C as C +import qualified Data.Set as Set + ;import Data.Set (Set) +import qualified Language.C as C + ;import Language.C as C hiding (prettyUsingInclude) +import Language.C.Data.Ident as C +import Language.C.Data.Node as C +import Language.C.Data.Position import Language.C.System.GCC import Language.C.System.Preprocess -import Language.C.Data.Position -import Language.Haskell.Exts.Parser as HS -import Language.Haskell.Exts.Pretty as HS -import Language.Haskell.Exts.Syntax as HS +import Language.Haskell.Exts.Parser as HS +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 Language.Haskell.TH.Syntax as TH import System.Directory import System.Environment +import System.Exit import System.IO import System.Process -import System.Exit -import Text.PrettyPrint (Doc, doubleQuotes, empty, text, vcat, ($$), - (<+>)) +import Text.PrettyPrint (Doc, doubleQuotes, empty, text, vcat, + ($$), (<+>)) import Text.Show.Pretty import Sweeten import GrepNested +import Unique {- trace :: p -> a -> a @@ -212,26 +215,34 @@ informalize :: FormalLambda -> HS.Exp () informalize (FormalLambda k x) = Lambda () [hspvar k] x +factorOutFunction :: String -- ^ New function name to factor out. + -> [String] -- ^ Arguments to function. + -> HS.Exp () -- ^ Body of function. + -> String -- ^ Variable name place holder for call sites in template. + -> HS.Exp () -- ^ Template containing place-holder call sites. + -> HS.Exp () +factorOutFunction k vs bdy govar expr = + let matchgo (Var () (UnQual () (HS.Ident () v))) = v==govar + matchgo _ = False + subst x | matchgo x = callsite + | otherwise = x + callsite = foldl (App ()) (hsvar k) $ map hsvar vs + pats = map hspvar vs + in Let () (BDecls () [FunBind () [HS.Match () (HS.Ident () k) pats + (UnGuardedRhs () bdy) Nothing]]) + (everywhere (mkT subst) expr) + -- Like applyComputation, but creates a let-binding rather than inlining the continuation. multiwayContinuation :: Computation FormalLambda -> Computation (HS.Exp ()) -> Computation (HS.Exp ()) multiwayContinuation a@Computation{ comp = FormalLambda govar exp } b = let k = uniqIdentifier "go" (foldr Map.union Map.empty [compFree a,compIntro a,compFree b,compIntro b]) vs = Map.keys $ compIntro a `Map.intersection` compFree b - matchgo (Var () (UnQual () (HS.Ident () v))) = v==govar - matchgo _ = False - subst x | matchgo x = callsite - | otherwise = x - callsite = foldl (App ()) (hsvar k) $ map hsvar vs - pats = map hspvar vs - letexpr = Let () (BDecls () [FunBind () [HS.Match () (HS.Ident () k) pats - (UnGuardedRhs () (comp b)) Nothing]]) - (everywhere (mkT subst) exp) in Computation { compFree = Map.union (compFree a) (compFree b) Map.\\ compIntro a , compIntro = compIntro a `Map.union` compIntro b , compContinue = Nothing - , comp = letexpr + , comp = factorOutFunction k vs (comp b) govar exp } @@ -698,6 +709,18 @@ grokStatement fe (CBlockDecl (CDecl (t:ts) (v:vs) _)) = do gs <- mapM (grokInitialization fe $ t:ts) initials return $ fmap (FormalLambda "go") $ foldr applyComputation (mkcomp $ hsvar "go") gs +grokStatement fe (CBlockStmt (CWhile cond (CCompound [] bdy _) isDoWhile _)) = do + gs <- mapM (grokStatement fe) bdy + (ss,c) <- grokExpression fe cond + let g = foldr applyComputation cnt gs -- body of loop + cnt = mkcomp $ hsvar " continue" + -- k = uniqIdentifier "go" (compFree g `Map.union` compIntro g) + loopcall = foldl (App ()) (hsvar "loop") $ map hsvar vs + -- c' = fmap (\cnd -> App () (App () (hsvar "when") cnd) (Paren () loopcall)) c + c' = fmap (\cnd -> If () cnd (Paren () loopcall) (hsvar "fin")) c + x = foldr applyComputation c' ss -- continue function + vs = [] -- Map.keys $ compIntro g + return $ fmap (FormalLambda "fin") $ fmap (factorOutFunction "continue" vs (comp x) " continue") g grokStatement fe _ = Nothing isFunctionDecl :: CExternalDeclaration a -> Bool -- cgit v1.2.3