Extract depth checks to common function

mengwong/mp/src/Lib.hs

@@ -18,12 +18,10 @@ import Data.ByteString.Lazy (ByteString)
 import qualified Data.Csv as Cassava
 import qualified Data.Vector as V
 import Generic.Data (Generic, Generically(..))
-import Data.Void (Void)
 import Data.Vector ((!), (!?))
 import Data.Maybe (listToMaybe, fromMaybe, catMaybes)
 import Text.Pretty.Simple (pPrint)
-import Control.Monad (guard, when)
-import Control.Monad.State
+import Control.Monad (guard, when, forM_)
 import qualified AnyAll as AA
 import qualified Text.PrettyPrint.Boxes as Box
 import           Text.PrettyPrint.Boxes hiding ((<>))
@@ -67,6 +65,18 @@ debugPrint str = whenDebug $ do
   where
     indent depth = replicate depth ' '
 
+-- | withDepth n p sets the depth to n for parser p
+withDepth :: Depth -> Parser a -> Parser a
+withDepth n = local (\st -> st {callDepth= n})
+
+-- | check that the next token is at at least the current level of indentation
+checkDepth :: Parser ()
+checkDepth = do
+  depth <- asks callDepth
+  leftX <- lookAhead pXLocation -- this is the column where we expect IF/AND/OR etc.
+  guard $ leftX >= depth
+
+
 runExample :: RunConfig -> ByteString -> IO ()
 runExample rc str = forM_ (exampleStreams str) $ \stream ->
     case runParser (runReaderT (pRule <* eof) rc) "dummy" stream of
@@ -204,7 +214,7 @@ toEOL :: Location -> [Location]
 toEOL loc = [ move loc E n | n <- [ 1 .. lineRemaining loc ] ]
 
 currentLine :: Location -> [Text.Text]
-currentLine loc = getCurrentCell <$> (toEOL $ lineStart loc)
+currentLine loc = getCurrentCell <$> toEOL (lineStart loc)
 
 lineStart :: Location -> Location
 lineStart loc = loc { cursor = (0, curY loc) }
@@ -293,21 +303,17 @@ pRule = withDepth 1 $ do
   try (pRegRule <?> "regulative rule")
     <|> (pConstitutiveRule <?> "constitutive rule")
 
-withDepth :: Int -> Parser a -> Parser a
-withDepth n = local (\st -> st {callDepth= n})
-
 pConstitutiveRule :: Parser [Rule]
 pConstitutiveRule = do
-  depth <- asks callDepth
   debugPrint "pConstitutiveRule"
   initialLocation <- lookAhead pXLocation
   myTraceM $ "pConstitutiveRule: initial location = " ++ show initialLocation
   term               <- (pOtherVal <* dnl) <?> "defined term"
 
   leftX              <- lookAhead pXLocation -- this is the column where we expect IF/AND/OR etc.
-  guard $ leftX >= depth
+  checkDepth
 
-  defWord            <- (pToken Means <|> pToken Is)
+  defWord            <- pToken Means <|> pToken Is
   myTraceM $ "pConstitutiveRule: matched defWord " ++ show defWord
   myTraceM $ "pConstitutiveRule: \"" ++ Text.unpack term ++ "\" " ++ show defWord ++ "..."
   (ands,rs) <- withDepth leftX dBoolRules -- (foo AND (bar OR baz), [constitutive and regulative sub-rules])
@@ -347,10 +353,9 @@ pRegRuleSugary = do
 
 pRegRuleNormal :: Parser [Rule]
 pRegRuleNormal = do
-  depth <- asks callDepth
   debugPrint "pRegRuleNormal"
   leftX              <- lookAhead pXLocation -- this is the column where we expect IF/AND/OR etc.
-  guard $ leftX >= depth
+  checkDepth
   (party_every, entitytype)   <- pActor Party <|> pActor Every
   -- (Who, (BoolStruct,[Rule]))
   whoBool                     <- optional (withDepth leftX preambleBoolRules)
@@ -441,12 +446,12 @@ newPre t (AA.Any (AA.PrePost p pp) x) = AA.Any (AA.PrePost t pp) x
 
 preambleBoolRules ::  Parser (Preamble, BoolRules)
 preambleBoolRules = do
-  depth <- asks callDepth
   leftX     <- lookAhead pXLocation -- this is the column where we expect IF/AND/OR etc.
   myTraceM ("preambleBoolRules: x location is " ++ show leftX)
-  guard $ leftX >= depth
+  checkDepth
+  depth <- asks callDepth
   myTraceM ("preambleBoolRules: passed guard! depth is " ++ show depth)
-  condWord <- (pToken Who <|> pToken When <|> pToken If)
+  condWord <- pToken Who <|> pToken When <|> pToken If
   myTraceM ("preambleBoolRules: found condWord: " ++ show condWord)
   (ands,rs) <- withDepth leftX dBoolRules -- (foo AND (bar OR baz), [constitutive and regulative sub-rules])
 --   let bs = if subForest ands) == 1 -- upgrade the single OR child of the AND group to the top level
@@ -504,10 +509,8 @@ constitutiveAsElement [] = error "constitutiveAsElement: cannot convert an empty
 
 pLeafVal ::  Parser BoolRules
 pLeafVal = do
-  depth <- asks callDepth
   debugPrint "pLeafVal"
-  currentX <- lookAhead pXLocation
-  guard $ currentX >= depth
+  checkDepth
   leafVal <- pOtherVal <* dnl
   myTraceM $ "pLeafVal returning " ++ Text.unpack leafVal
   return (Just (AA.Leaf leafVal), [])
@@ -524,12 +527,11 @@ pNestedBool = do
   myTraceM $ "pNestedBool returning " ++ show toreturn
   return toreturn
 
+pBoolConnector :: Parser MyToken
 pBoolConnector = do
-  depth <- asks callDepth
   debugPrint "pBoolConnector"
-  currentX <- lookAhead pXLocation
-  guard $ currentX >= depth
-  andor <- (pToken And <|> pToken Or <|> pToken Unless)
+  checkDepth
+  andor <- pToken And <|> pToken Or <|> pToken Unless
   myTraceM $ "pBoolConnector returning " ++ show andor
   return andor