Use the ReaderT to avoid threading depth everywhere

mengwong/mp/src/Lib.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE TypeFamilies      #-}
 {-# LANGUAGE BangPatterns #-}
+{-# OPTIONS_GHC -Wall #-}
 
 module Lib where
 
@@ -35,7 +36,7 @@ import Debug.Trace
 
 import Types
 import Error
-import Control.Monad.Reader (ReaderT(runReaderT), asks)
+import Control.Monad.Reader (ReaderT(runReaderT), asks, MonadReader (local))
 
 -- our task: to parse an input CSV into a collection of Rules.
 -- example "real-world" input can be found at https://docs.google.com/spreadsheets/d/1qMGwFhgPYLm-bmoN2es2orGkTaTN382pG2z3RjZ_s-4/edit
@@ -55,15 +56,16 @@ whenDebug act = do
   isDebug <- asks debug
   when isDebug act
 
+myTraceM :: String -> Parser ()
 myTraceM x = whenDebug (traceM x)
 
-debugPrint :: Int -> String -> ReaderT RunConfig (Parsec Void MyStream) ()
-
-debugPrint depth str = whenDebug $ do
+debugPrint :: String -> Parser ()
+debugPrint str = whenDebug $ do
   lookingAt <- lookAhead (getToken :: Parser MyToken)
-  myTraceM $ indent <> str <> " running. depth=" <> show depth <> "; looking at: " <> show lookingAt
+  depth <- asks callDepth
+  myTraceM $ indent depth <> str <> " running. depth=" <> show depth <> "; looking at: " <> show lookingAt
   where
-    indent = replicate depth ' '
+    indent depth = replicate depth ' '
 
 runExample :: RunConfig -> ByteString -> IO ()
 runExample rc str = forM_ (exampleStreams str) $ \stream ->
@@ -286,14 +288,18 @@ stanzaAsStream s rs = do
 
 -- the goal is tof return a list of Rule, which an be either regulative or constitutive:
 pRule :: Parser [Rule]
-pRule = do
+pRule = withDepth 1 $ do
   dnl
-  try (pRegRule 1 <?> "regulative rule")
-    <|> (pConstitutiveRule 1 <?> "constitutive rule")
+  try (pRegRule <?> "regulative rule")
+    <|> (pConstitutiveRule <?> "constitutive rule")
+
+withDepth :: Int -> Parser a -> Parser a
+withDepth n = local (\st -> st {callDepth= n})
 
-pConstitutiveRule :: Depth -> Parser [Rule]
-pConstitutiveRule depth = do
-  debugPrint depth "pConstitutiveRule"
+pConstitutiveRule :: Parser [Rule]
+pConstitutiveRule = do
+  depth <- asks callDepth
+  debugPrint "pConstitutiveRule"
   initialLocation <- lookAhead pXLocation
   myTraceM $ "pConstitutiveRule: initial location = " ++ show initialLocation
   term               <- (dnl *> pOtherVal <* dnl) <?> "defined term"
@@ -304,22 +310,22 @@ pConstitutiveRule depth = do
   defWord            <- (pToken Means <|> pToken Is)  <* dnl
   myTraceM $ "pConstitutiveRule: matched defWord " ++ show defWord
   myTraceM $ "pConstitutiveRule: \"" ++ Text.unpack term ++ "\" " ++ show defWord ++ "..."
-  (ands,rs) <- dBoolRules leftX -- (foo AND (bar OR baz), [constitutive and regulative sub-rules])
+  (ands,rs) <- withDepth leftX dBoolRules -- (foo AND (bar OR baz), [constitutive and regulative sub-rules])
   let toreturn = Constitutive term ands : rs
   myTraceM $ "pConstitutiveRule: returning " ++ show toreturn
   return toreturn
 
-pRegRule depth = try (pRegRuleSugary depth) <|> pRegRuleNormal depth
+pRegRule = try pRegRuleSugary <|> pRegRuleNormal
 
 -- "You MAY" has no explicit PARTY or EVERY keyword
-pRegRuleSugary :: Depth -> Parser [Rule]
-pRegRuleSugary depth = do
-  debugPrint depth "pRegRuleSugary"
+pRegRuleSugary :: Parser [Rule]
+pRegRuleSugary = do
+  debugPrint "pRegRuleSugary"
   entitytype         <- pOtherVal <* dnl
   leftX              <- lookAhead pXLocation -- this is the column where we expect IF/AND/OR etc.
   deontic            <- pDeontic <* dnl
   temporal           <- optional pTemporal
-  rulebody           <- permutations depth
+  rulebody           <- permutations
   let (who, (ands, brs)) = mergePBRS (if null (rbpbrs rulebody) then [(Always, (Nothing, []))] else rbpbrs rulebody)
       toreturn = Regulative
                  entitytype
@@ -338,16 +344,17 @@ pRegRuleSugary depth = do
 -- BEFORE  midnight
 -- IF      a potato is available
 
-pRegRuleNormal :: Depth -> Parser [Rule]
-pRegRuleNormal depth = do
-  debugPrint depth "pRegRuleNormal"
+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
   (party_every, entitytype)   <- pActor Party <|> pActor Every
   -- (Who, (BoolStruct,[Rule]))
-  whoBool                     <- optional (preambleBoolRules leftX)               <* dnl
+  whoBool                     <- optional (withDepth leftX preambleBoolRules)               <* dnl
   -- the below are going to be permutables
-  rulebody <- permutations depth
+  rulebody <- permutations
   -- deontic            <- pDeontic                                                <* dnl
   -- temporal           <- optional pTemporal
   -- action             <- pAction
@@ -387,8 +394,8 @@ pActor party = do
   entitytype         <- pToken party *> many pEmpty *> pOtherVal <* dnl
   return (party, entitytype)
 
-pAction :: Depth -> Parser ActionType
-pAction depth = do
+pAction ::  Parser ActionType
+pAction = do
   action <- pToken Do *> many pEmpty *> pOtherVal          <* dnl
   params <- many (pOtherVal <* dnl) -- it'd be nice to have newline detection
   return (action, list2tuples params)
@@ -409,11 +416,11 @@ data RuleBody = RuleBody { rbpbrs     :: [(Preamble, BoolRules)] -- not subject
                       deriving (Eq, Show, Generic)
                       deriving (Semigroup, Monoid) via Generically RuleBody
 
-permutations :: Depth -> Parser RuleBody
-permutations depth = do
+permutations ::  Parser RuleBody
+permutations = do
   toreturn <- permute ((\a b c d -> mconcat [a,b,c,d])
-                        <$$> ( (\a -> RuleBody [] [a] [] []) <$> pAction depth )
-                        <||> ( (\a -> RuleBody a [] [] [])   <$> many (preambleBoolRules depth) <* dnl ) -- WHO xxx, IF yyy
+                        <$$> ( (\a -> RuleBody [] [a] [] []) <$> pAction )
+                        <||> ( (\a -> RuleBody a [] [] [])   <$> many preambleBoolRules <* dnl ) -- WHO xxx, IF yyy
                         <||> ( (\a -> RuleBody [] [] [a] []) <$> pDeontic )
                         <|?> ( mempty, (\a -> RuleBody [] [] [] [a]) <$> pTemporal )
                       )
@@ -428,15 +435,16 @@ newPre t (AA.All (AA.PrePost p pp) x) = AA.All (AA.PrePost t pp) x
 newPre t (AA.Any (AA.Pre     p)    x) = AA.Any (AA.Pre     t   ) x
 newPre t (AA.Any (AA.PrePost p pp) x) = AA.Any (AA.PrePost t pp) x
 
-preambleBoolRules :: Depth -> Parser (Preamble, BoolRules)
-preambleBoolRules depth = do
+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
   myTraceM ("preambleBoolRules: passed guard! depth is " ++ show depth)
   condWord <- (pToken Who <|> pToken When <|> pToken If)   <* dnl
   myTraceM ("preambleBoolRules: found condWord: " ++ show condWord)
-  (ands,rs) <- dBoolRules leftX -- (foo AND (bar OR baz), [constitutive and regulative sub-rules])
+  (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
 --            then newPre (Text.pack $ show condWord) (head ands)
 --            else AA.All (AA.Pre (Text.pack $ show condWord)) ands -- return the AND group
@@ -445,53 +453,55 @@ preambleBoolRules depth = do
   myTraceM $ "preambleBoolRules: returning " ++ show toreturn
   return toreturn
 
-dBoolRules :: Depth -> Parser BoolRules
-dBoolRules depth = do
-  debugPrint depth "dBoolRules"
-  ands     <- pAndGroup depth -- walks AND eats OR drinks
+dBoolRules ::  Parser BoolRules
+dBoolRules = do
+  debugPrint "dBoolRules"
+  ands     <- pAndGroup -- walks AND eats OR drinks
   myTraceM $ "dBoolRules: returning ands: " ++ show ands
   return ands
 
-pAndGroup :: Depth -> Parser BoolRules
-pAndGroup depth = do
-  debugPrint depth "pAndGroup"
+pAndGroup ::  Parser BoolRules
+pAndGroup = do
+  debugPrint "pAndGroup"
   currentX <- lookAhead pXLocation -- we are positioned at the OtherVal
-  orGroup1 <- pOrGroup depth                                                <* dnl
-  orGroupN <- many $ dToken depth And *> many pEmpty *> pOrGroup depth      <* dnl
+  orGroup1 <- pOrGroup                                                <* dnl
+  orGroupN <- many $ dToken And *> many pEmpty *> pOrGroup      <* dnl
   let toreturn = if null orGroupN
                  then orGroup1
                  else ( Just (AA.All (AA.Pre "all of:") (catMaybes $ fst <$> (orGroup1 : orGroupN)))
                       , concatMap snd (orGroup1 : orGroupN) )
   myTraceM $ "pAndGroup: returning " ++ show toreturn
   return toreturn
 
-pOrGroup :: Depth -> Parser BoolRules
-pOrGroup depth = do
-  debugPrint depth "pOrGroup"
-  elem1    <- pElement (depth + 1)                                      <* dnl
-  elems    <- many $ dToken depth Or *> many pEmpty *> pElement (depth+1)    <* dnl
+pOrGroup ::  Parser BoolRules
+pOrGroup = do
+  depth <- asks callDepth
+  debugPrint "pOrGroup"
+  elem1    <- withDepth (depth + 1) pElement                                      <* dnl
+  elems    <- many $ dToken Or *> many pEmpty *> withDepth (depth+1) pElement     <* dnl
   let toreturn = if null elems
                  then elem1
                  else ( Just (AA.Any (AA.Pre "any of:") (catMaybes $ fst <$> (elem1 : elems)))
                       , concatMap snd (elem1 : elems) )
   myTraceM $ "pOrGroup: returning " ++ show toreturn
   return toreturn
 
-pElement :: Depth -> Parser BoolRules
-pElement depth = do
-  debugPrint depth "pElement"
+pElement ::  Parser BoolRules
+pElement = do
+  debugPrint "pElement"
   -- think about importing Control.Applicative.Combinators so we get the `try` for free
-  try (pNestedBool depth)
-    <|> try (constitutiveAsElement <$> pConstitutiveRule depth)
-    <|> try (pLeafVal depth)
+  try pNestedBool
+    <|> try (constitutiveAsElement <$> pConstitutiveRule)
+    <|> try pLeafVal
 
 constitutiveAsElement :: [Rule] -> BoolRules
 constitutiveAsElement (cr:rs) = (Just (AA.Leaf (term cr)), cr:rs)
 constitutiveAsElement [] = error "constitutiveAsElement: cannot convert an empty list of rules to a BoolRules structure!"
 
-pLeafVal :: Depth -> Parser BoolRules
-pLeafVal depth = do
-  debugPrint depth "pLeafVal"
+pLeafVal ::  Parser BoolRules
+pLeafVal = do
+  depth <- asks callDepth
+  debugPrint "pLeafVal"
   currentX <- lookAhead pXLocation
   guard $ currentX >= depth
   leafVal <- pOtherVal <* dnl
@@ -500,22 +510,23 @@ pLeafVal depth = do
 
 -- should be possible to merge pLeafVal with pNestedBool.
 
-pNestedBool :: Depth -> Parser BoolRules
-pNestedBool depth = do
-  debugPrint depth "pNestedBool"
+pNestedBool ::  Parser BoolRules
+pNestedBool = do
+  debugPrint "pNestedBool"
   -- "foo AND bar" is a nestedBool; but just "foo" is a leafval.
-  foundBool <- lookAhead (pLeafVal depth >> pBoolConnector depth)
+  foundBool <- lookAhead (pLeafVal >> pBoolConnector)
   myTraceM $ "pNestedBool matched " ++ show foundBool
-  toreturn <- dBoolRules depth
+  toreturn <- dBoolRules
   myTraceM $ "pNestedBool returning " ++ show toreturn
   return toreturn
 
-pBoolConnector depth = do
-  debugPrint depth "pBoolConnector"
+pBoolConnector = do
+  depth <- asks callDepth
+  debugPrint "pBoolConnector"
   currentX <- lookAhead pXLocation
   guard $ currentX >= depth
   andor <- (pToken And <|> pToken Or <|> pToken Unless) <* dnl
-  myTraceM $ "pBoolConnector returning " ++ (show andor)
+  myTraceM $ "pBoolConnector returning " ++ show andor
   return andor
 
 -- helper functions for parsing

mengwong/mp/src/Types.hs

@@ -15,7 +15,7 @@ import Data.Void (Void)
 import qualified Data.Set           as Set
 import Control.Monad
 import qualified AnyAll as AA
-import Control.Monad.Reader (ReaderT)
+import Control.Monad.Reader (ReaderT, asks)
 
 type RawStanza = V.Vector (V.Vector Text.Text) -- "did I stammer?"
 type Parser = ReaderT RunConfig (Parsec Void MyStream)
@@ -216,8 +216,9 @@ liftMyToken = WithPos pos pos 0
 pToken :: MyToken -> Parser MyToken
 pToken c = pTokenMatch (== c) c
 
-dToken :: Depth -> MyToken -> Parser MyToken
-dToken d c = do
+dToken :: MyToken -> Parser MyToken
+dToken c = do
+  d <- asks callDepth
   currentX <- lookAhead pXLocation
   guard $ currentX >= d
   pTokenMatch (== c) c