Adds while until to block expressions

Makefile

@@ -1,5 +1,5 @@
 build:
-	stack build # csound-expression # -dynamic
+	stack build csound-expression
 
 bench:
 	stack build csound-expression:bench:csound-expression-benchmark  # --profile

csound-expression-dynamic/src/Csound/Dynamic/Build/Logic.hs

@@ -6,10 +6,14 @@ module Csound.Dynamic.Build.Logic(
     ifExp,
     ifElseBlock,
     -- ifBegin, ifEnd, elseBegin,
-    untilDo,
-    untilBegin, untilEnd,
-    whileDo,
-    whileBegin, whileRef, whileEnd
+    untilBlock,
+    whileBlock,
+
+    -- untilDo,
+    -- untilBegin, untilEnd,
+    -- whileDo,
+    -- whileBegin,
+    whileRef, whileEnd
 ) where
 
 import Control.Monad
@@ -43,11 +47,19 @@ ifT ifRate check (DepT th) (DepT el) = DepT $ StateT $ \s -> do
       }
 
 
-ifT1 :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m E
-ifT1 ifRate check (DepT th) = DepT $ StateT $ \s -> do
+ifT1, untilT, whileT :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m E
+
+ifT1 = ifT1By IfBlock
+untilT = ifT1By UntilBlock
+whileT = ifT1By WhileBlock
+
+ifT1By :: Monad m
+  => (IfRate -> CondInfo (PrimOr E) -> CodeBlock (PrimOr E) -> Exp E)
+  -> IfRate -> E -> DepT m (CodeBlock E) -> DepT m E
+ifT1By cons ifRate check (DepT th) = DepT $ StateT $ \s -> do
   (_thE, thS)  <- runStateT th (startSt s)
   let thDeps = expDependency thS
-      a  = noRate $ IfBlock ifRate (condInfo $ setIfRate ifRate check) (CodeBlock $ PrimOr $ Right thDeps)
+      a  = noRate $ cons ifRate (condInfo $ setIfRate ifRate check) (CodeBlock $ PrimOr $ Right thDeps)
       a1 = rehashE $ Fix $ (unFix a) { ratedExpDepends = Just (newLineNum thS) }
       s1 = thS
             { newLineNum = succ $ newLineNum thS
@@ -71,36 +83,12 @@ setIfRate rate = setRate (fromIfRate rate)
 
 when1 :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m ()
 when1 ifRate p body = void $ ifT1 ifRate p body
-{-  bodyE <- body
-  depT_ $ noRate $
-    IfBlock ifRate
-      (condInfo $ setIfRate ifRate p)
-      (PrimOr . Right <$> bodyE)
-  -}
-
-{-
-    ifBegin rate p
-    body
-    ifEnd
--}
 
 whens :: Monad m => IfRate -> [(E, DepT m (CodeBlock E))] -> DepT m (CodeBlock E) -> DepT m ()
 whens rate bodies el =
   void $ List.foldl' go el (List.reverse bodies)
   where
     go res (check, th) = CodeBlock <$> ifT rate check th res
-{-
-case bodies of
-    []   -> el
-    a:as -> do
-        ifBegin rate (fst a)
-        snd a
-        elseIfs as
-        elseBegin
-        el
-        foldl1 (>>) $ replicate (1 + length as) ifEnd
-    where elseIfs = mapM_ (\(p, body) -> elseBegin >> ifBegin rate p >> body)
--}
 
 ifElseBlock :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m (CodeBlock E) -> DepT m ()
 ifElseBlock rate p th el = void $ ifElseBlock rate p th el
@@ -129,6 +117,13 @@ ifEnd :: Monad m => DepT m ()
 ifEnd = stmtOnlyT IfEnd
 -}
 
+untilBlock :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m ()
+untilBlock ifRate p body = void $ untilT ifRate p body
+
+whileBlock :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m ()
+whileBlock ifRate p body = void $ whileT ifRate p body
+
+{-
 untilDo :: Monad m => IfRate -> E -> DepT m () -> DepT m ()
 untilDo ifRate p body = do
     untilBegin ifRate p
@@ -140,7 +135,9 @@ untilBegin ifRate = withCond ifRate (UntilBegin ifRate)
 
 untilEnd :: Monad m => DepT m ()
 untilEnd = stmtOnlyT UntilEnd
+-}
 
+{-
 whileDo :: Monad m => IfRate -> E -> DepT m () -> DepT m ()
 whileDo ifRate p body = do
     whileBegin ifRate p
@@ -149,15 +146,18 @@ whileDo ifRate p body = do
 
 whileBegin :: Monad m => IfRate -> E -> DepT m ()
 whileBegin ifRate = withCond IfKr (WhileBegin ifRate)
+-}
 
 whileRef :: Monad m => Var -> DepT m ()
 whileRef var = stmtOnlyT $ WhileRefBegin var
 
 whileEnd :: Monad m => DepT m ()
 whileEnd = stmtOnlyT WhileEnd
 
+{-
 withCond :: Monad m => IfRate -> (CondInfo (PrimOr E) -> MainExp (PrimOr E)) -> E -> DepT m ()
 withCond ifRate stmt p = depT_ $ noRate $ stmt (condInfo $ setIfRate ifRate p)
+-}
 
 instance Boolean E where
     true = boolOp0 TrueOp

csound-expression-dynamic/src/Csound/Dynamic/Render/Pretty.hs

@@ -159,11 +159,15 @@ ppExp res expr = case fmap ppPrimOrVar expr of
     TfmArr isInit v op xs                  -> tab $ ppOpc (ppTfmArrOut isInit v) (infoName op) xs
 
     IfBegin _ a                     -> succTab          $ text "if "     <> ppCond a <> text " then"
-    IfBlock _ cond (CodeBlock th) -> tab $ ppIf res (ppCond cond)  th th
+    IfBlock _ cond (CodeBlock th) ->  tab $ ppIf1 res (ppCond cond)  th
     IfElseBlock _ cond (CodeBlock th) (CodeBlock el) -> tab $ ppIf res (ppCond cond)  th el
 --     ElseIfBegin a                   -> left >> (succTab $ text "elseif " <> ppCond a <> text " then")
     ElseBegin                       -> left >> (succTab $ text "else")
     IfEnd                           -> left >> (tab     $ text "endif")
+    UntilBlock _ cond (CodeBlock th) -> tab $ ppUntil res (ppCond cond)  th
+    WhileBlock _ cond (CodeBlock th) -> tab $ ppWhile res (ppCond cond)  th
+    WhileRefBlock var (CodeBlock th) -> tab $ ppWhileRef res var th
+
     UntilBegin _ a                  -> succTab          $ text "until " <> ppCond a <> text " do"
     UntilEnd                        -> left >> (tab     $ text "od")
     WhileBegin _ a                  -> succTab          $ text "while " <> ppCond a <> text " do"
@@ -269,6 +273,26 @@ ppIf res p t e = vcat
     , text "endif"
     ]
 
+ppIf1, ppWhile, ppUntil :: Doc -> Doc -> Doc -> Doc
+
+ppIf1 = ppIfBy "if"
+ppWhile = ppIfBy "while"
+ppUntil = ppIfBy "until"
+
+ppIfBy :: Text -> Doc -> Doc -> Doc -> Doc
+ppIfBy leadTag res p t = vcat
+    [ textStrict leadTag <+> p <+> text "then"
+    , text "    " <> res <+> char '=' <+> t
+    , text "endif"
+    ]
+
+ppWhileRef :: Doc -> Var -> Doc -> Doc
+ppWhileRef res p t = vcat
+    [ textStrict "while" <+> ppVar p <+> text "then"
+    , text "    " <> res <+> char '=' <+> t
+    , text "endif"
+    ]
+
 ppOpc :: Doc -> Text -> [Doc] -> Doc
 ppOpc out name xs = out <+> ppProc name xs
 
@@ -389,7 +413,6 @@ ppE = foldFix go
 
     ppHash = textStrict . Text.take 4 . Text.decodeUtf8 . Base64.encode
 
-
     fromExp :: Doc -> RatedExp Doc -> Doc
     fromExp info RatedExp{..} = indent 2 $ post $
       case ratedExpExp of
@@ -412,11 +435,8 @@ ppE = foldFix go
         TfmArr _isInit _v _info _args -> undefined
 
         IfBegin rate cond -> hsep ["IF", ppRate $ fromIfRate rate, ppCond $ fmap pp cond, "\n"]
-        IfBlock rate cond (CodeBlock th) ->
-          ppFun (hsep ["IF-BLOCK", ppRate $ fromIfRate rate, ppCond $ fmap pp cond ])
-            [ pp th
-            , "END-BLOCK"
-            ]
+
+        IfBlock rate cond (CodeBlock th) -> ppIfBlockBy "IF-BLOCK" rate cond th
         IfElseBlock rate cond (CodeBlock th) (CodeBlock el) ->
           ppFun (hsep ["IF-BLOCK", ppRate $ fromIfRate rate, ppCond $ fmap pp cond ])
             [ pp th
@@ -431,6 +451,11 @@ ppE = foldFix go
         WhileBegin rate cond -> hsep ["WHILE", ppRate $ fromIfRate rate, ppCond $ fmap pp cond, "\n"]
         WhileRefBegin v -> hsep ["WHILE_REF", ppVar v]
         WhileEnd -> "END_WHILE"
+
+        UntilBlock rate cond (CodeBlock th) -> ppIfBlockBy "UNTIL-BLOCK" rate cond th
+        WhileBlock rate cond (CodeBlock th) -> ppIfBlockBy "WHILE-BLOCK" rate cond th
+        WhileRefBlock var (CodeBlock th) -> ppWhileRefBlock var th
+
         Verbatim txt -> ppFun "VERBATIM" [textStrict txt]
         Starts -> "STARTS"
         Seq a b -> vcat ["SEQ", pp a, pp b]
@@ -444,6 +469,18 @@ ppE = foldFix go
       where
         post a = hsep [hcat ["{",info, "}:"], a]
 
+    ppIfBlockBy leadTag rate cond th =
+      ppFun (hsep [leadTag, ppRate $ fromIfRate rate, ppCond $ fmap pp cond ])
+        [ pp th
+        , "END-BLOCK"
+        ]
+
+    ppWhileRefBlock var th =
+      ppFun (hsep ["WHILE-REF-BLOCK", ppVar var])
+        [ pp th
+        , "END-BLOCK"
+        ]
+
     ppTfm info args = ppFun (textStrict $ infoName info) (fmap pp args)
 
     ppConvert to from a =

csound-expression-dynamic/src/Csound/Dynamic/Tfm/IfBlocks.hs

@@ -1,4 +1,4 @@
--- | We collect all if-blocks under the if-the-else constructs.
+-- | We collect all if-blocks under the if-the-else expressions and statements.
 --
 -- For a given if-block of code the taks is to agregate all expressions
 -- that can be used inside that block and don't affect external expressions
@@ -563,7 +563,8 @@ getExprType expr =
     IfBlock rate c (CodeBlock th) -> IfType rate c th $ IfCons { ifBegin = IfBegin, ifEnd = IfEnd }
     IfElseBlock rate c (CodeBlock th) (CodeBlock el) -> -- trace (unlines ["TH/EL", show (th, el)])
       IfElseType rate c th el $ IfElseCons { ifElseBegin = IfBegin, elseBegin = ElseBegin, ifElseEnd = IfEnd }
+    WhileBlock rate c (CodeBlock th) -> IfType rate c th $ IfCons { ifBegin = WhileBegin, ifEnd = WhileEnd }
+    UntilBlock rate c (CodeBlock th) -> IfType rate c th $ IfCons { ifBegin = UntilBegin, ifEnd = UntilEnd }
     -- TODO:
-    --     While case
-    --     Until case
+    --     While Ref case
     _ -> PlainType

csound-expression-dynamic/src/Csound/Dynamic/Tfm/InferTypes.hs

@@ -226,6 +226,10 @@ inferIter opts (Stmt lhs rhs) =
     ReadMacrosString name -> save Ir (ReadMacrosString name)
 
     -- | looping constructions
+    UntilBlock ifRate cond th -> onUntilBlock ifRate cond th
+    WhileBlock ifRate cond th -> onWhileBlock ifRate cond th
+    WhileRefBlock var th -> onWhileRefBlock var th
+
     UntilBegin ifRate cond -> onUntilBegin ifRate cond
     UntilEnd -> saveProcedure UntilEnd
     WhileBegin ifRate cond -> onWhileBegin ifRate cond
@@ -374,11 +378,21 @@ inferIter opts (Stmt lhs rhs) =
               save Kr (If ifRate condVarSafe thVar1 elVar1)
           | otherwise  = save rate (If ifRate condVarSafe thVar elVar)
 
-    onIfBlock ifRate cond th = do
+    onIfBlock = onIfBlockBy IfBlock
+
+    onUntilBlock = onIfBlockBy UntilBlock
+
+    onWhileBlock = onIfBlockBy WhileBlock
+
+    onWhileRefBlock var th = do
+      setHasIfs
+      saveProcedure (WhileRefBlock var (fmap (Var Xr) <$> th))
+
+    onIfBlockBy cons ifRate cond th = do
       setHasIfs
       condVar <- mapM (mapM $ getVar condMaxRate) cond
       condVarSafe <- insertBoolConverters condMaxRate condVar
-      saveProcedure (IfBlock ifRate condVarSafe (fmap (Var Xr) <$> th))
+      saveProcedure (cons ifRate condVarSafe (fmap (Var Xr) <$> th))
       where
         condMaxRate = fromIfRate ifRate
 

csound-expression-dynamic/src/Csound/Dynamic/Types/Exp.hs

@@ -200,9 +200,12 @@ data MainExp a
     | ElseBegin
     | IfEnd
     -- | looping constructions
-    | UntilBegin IfRate !(CondInfo a)
+    | UntilBlock !IfRate !(CondInfo a) (CodeBlock a)
+    | UntilBegin !IfRate !(CondInfo a)
     | UntilEnd
-    | WhileBegin IfRate !(CondInfo a)
+    | WhileBlock !IfRate !(CondInfo a) (CodeBlock a)
+    | WhileBegin !IfRate !(CondInfo a)
+    | WhileRefBlock !Var !(CodeBlock a)
     | WhileRefBegin !Var
     | WhileEnd
     -- | Verbatim stmt