WIP: do-while.

3 files changed, 93 insertions, 29 deletions

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