From 618b300aa77162ab62a10cb0670ab8f76b5bb0a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Mon, 18 Oct 2021 11:30:34 +0800 Subject: [PATCH] Use the ReaderT to avoid threading depth everywhere --- mengwong/mp/src/Lib.hs | 137 +++++++++++++++++++++------------------ mengwong/mp/src/Types.hs | 7 +- 2 files changed, 78 insertions(+), 66 deletions(-) diff --git a/mengwong/mp/src/Lib.hs b/mengwong/mp/src/Lib.hs index 39857cb1..bb5ac67f 100644 --- a/mengwong/mp/src/Lib.hs +++ b/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,19 +453,19 @@ 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))) @@ -465,11 +473,12 @@ pAndGroup depth = do 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))) @@ -477,21 +486,22 @@ pOrGroup depth = do 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 diff --git a/mengwong/mp/src/Types.hs b/mengwong/mp/src/Types.hs index 36226422..a418e54d 100644 --- a/mengwong/mp/src/Types.hs +++ b/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