Skip to content

Commit

Permalink
set boolstructs to be Maybes in Regulative. still failing test.
Browse files Browse the repository at this point in the history
  • Loading branch information
@mengwong
mengwong committed Oct 13, 2021
1 parent 5c0e9dc commit 3dcfe1a
Show file tree
Hide file tree
Showing 3 changed files with 30 additions and 24 deletions.
22 changes: 11 additions & 11 deletions mengwong/mp/src/Lib.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,7 +19,7 @@ import qualified Data.Vector as V
import Generic.Data (Generic, Generically(..))
import Data.Void (Void)
import Data.Vector ((!), (!?))
import Data.Maybe (listToMaybe, fromMaybe)
import Data.Maybe (listToMaybe, fromMaybe, catMaybes)
import Text.Pretty.Simple (pPrint)
import Control.Monad (guard, when)
import Control.Monad.State
Expand Down Expand Up @@ -48,7 +48,7 @@ someFunc = do

-- TODO: integrate debugging and callstack depth with the runConfig, thread it through all the functions here
-- printf debugging infrastructure
debuggery = True
debuggery = False
myTraceM x = when debuggery (traceM x)
debugPrint depth str = when debuggery $ do
lookingAt <- lookAhead (getToken :: Parser MyToken)
Expand Down Expand Up @@ -303,10 +303,10 @@ pRegRuleSugary depth = do
deontic <- pDeontic <* dnl
temporal <- optional pTemporal
rulebody <- permutations depth
let (who, (ands, brs)) = mergePBRS (if null (rbpbrs rulebody) then [(Always, (AA.Leaf "always", []))] else rbpbrs rulebody)
let (who, (ands, brs)) = mergePBRS (if null (rbpbrs rulebody) then [(Always, (Nothing, []))] else rbpbrs rulebody)
toreturn = Regulative
entitytype
(AA.Leaf "unit")
Nothing
ands
(head $ rbdeon rulebody)
(head $ rbaction rulebody)
Expand Down Expand Up @@ -334,11 +334,11 @@ pRegRuleNormal depth = do
-- deontic <- pDeontic <* dnl
-- temporal <- optional pTemporal
-- action <- pAction
let (who, (cbs, brs)) = mergePBRS (if null (rbpbrs rulebody) then [(Always, (AA.Leaf "always", []))] else rbpbrs rulebody)
let (ewho, (ebs, ebrs)) = fromMaybe (Always, (AA.Leaf "always", [])) whoBool
let (who, (cbs, brs)) = mergePBRS (if null (rbpbrs rulebody) then [(Always, (Nothing, []))] else rbpbrs rulebody)
let (ewho, (ebs, ebrs)) = fromMaybe (Always, (Nothing, [])) whoBool
let toreturn = Regulative
entitytype
(newPre (Text.pack $ show ewho) ebs)
(newPre (Text.pack $ show ewho) <$> ebs)
cbs
(head $ rbdeon rulebody)
(head $ rbaction rulebody)
Expand Down Expand Up @@ -443,7 +443,7 @@ pAndGroup depth = do
orGroupN <- many $ dToken depth And *> many pEmpty *> pOrGroup depth <* dnl
let toreturn = if null orGroupN
then orGroup1
else ( AA.All (AA.Pre "all of:") (map fst (orGroup1 : orGroupN))
else ( Just (AA.All (AA.Pre "all of:") (catMaybes $ fst <$> (orGroup1 : orGroupN)))
, concatMap snd (orGroup1 : orGroupN) )
myTraceM $ "pAndGroup: returning " ++ show toreturn
return toreturn
Expand All @@ -455,7 +455,7 @@ pOrGroup depth = do
elems <- many $ dToken depth Or *> many pEmpty *> pElement (depth+1) <* dnl
let toreturn = if null elems
then elem1
else ( AA.Any (AA.Pre "any of:") (fst <$> (elem1 : elems))
else ( Just (AA.Any (AA.Pre "any of:") (catMaybes $ fst <$> (elem1 : elems)))
, concatMap snd (elem1 : elems) )
myTraceM $ "pOrGroup: returning " ++ show toreturn
return toreturn
Expand All @@ -469,7 +469,7 @@ pElement depth = do
<|> try (pLeafVal depth)

constitutiveAsElement :: [Rule] -> BoolRules
constitutiveAsElement (cr:rs) = (AA.Leaf (term cr), cr:rs)
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
Expand All @@ -479,7 +479,7 @@ pLeafVal depth = do
guard $ currentX >= depth
leafVal <- pOtherVal <* dnl
myTraceM $ "pLeafVal returning " ++ Text.unpack leafVal
return (AA.Leaf leafVal, [])
return (Just (AA.Leaf leafVal), [])

-- should be possible to merge pLeafVal with pNestedBool.

Expand Down
9 changes: 5 additions & 4 deletions mengwong/mp/src/Types.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -20,19 +20,20 @@ type RawStanza = V.Vector (V.Vector Text.Text) -- "did I stammer?"
type Parser = Parsec Void MyStream
type Depth = Int
type Preamble = MyToken
type BoolRules = (BoolStruct, [Rule])
type BoolRules = (Maybe BoolStruct, [Rule])

data Rule = Regulative
{ every :: EntityType -- every person
, who :: BoolStruct -- who walks and (eats or drinks)
, cond :: BoolStruct -- if it is a saturday
, who :: Maybe BoolStruct -- who walks and (eats or drinks)
, cond :: Maybe BoolStruct -- if it is a saturday
, deontic :: Deontic -- must
, action :: ActionType -- sing
, temporal :: Maybe (TemporalConstraint Text.Text) -- Before "midnight"
}
| Constitutive
{ term :: ConstitutiveTerm
, cond :: BoolStruct
, cond :: Maybe BoolStruct
-- , valu :: Text.Text
}
deriving (Eq, Show)
-- everything is stringly typed at the moment but as this code matures these will become more specialized.
Expand Down
23 changes: 14 additions & 9 deletions mengwong/mp/test/Spec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -22,7 +22,8 @@ main = hspec $ do
`shouldParse`
[ Regulative {
every = "person"
, who = Any ( Pre "Always" ) [ ]
, who = Just (Any ( Pre "Always" ) [ ])
, cond = Nothing
, deontic = DMust
, action = ("sing",[])
, temporal = Nothing
Expand All @@ -33,7 +34,8 @@ main = hspec $ do
`shouldParse`
[ Regulative {
every = "person"
, who = Leaf "walks"
, who = Just (Leaf "walks")
, cond = Nothing
, deontic = DMust
, action = ("sing",[])
, temporal = Nothing
Expand All @@ -44,7 +46,7 @@ main = hspec $ do
`shouldParse`
[ Regulative {
every = "person"
, who = All
, who = Just (All
( Pre "Who" )
[ Leaf "walks"
, Leaf "runs"
Expand All @@ -53,23 +55,25 @@ main = hspec $ do
[ Leaf "eats"
, Leaf "drinks"
]
]
])
, cond = Nothing
, deontic = DMust
, action = ("sing", [])
, temporal = Nothing
} ]

let imbibeRule = [ Regulative {
every = "person"
, who = Any
, who = Just (Any
( Pre "Who" )
[ Leaf "walks"
, Leaf "runs"
, Leaf "eats"
, All ( Pre "all of:" )
[ Leaf "drinks"
, Leaf "swallows" ]
]
])
, cond = Nothing
, deontic = DMust
, action = ("sing", [])
, temporal = Nothing
Expand All @@ -90,7 +94,7 @@ main = hspec $ do

let degustates = Constitutive
{ term = "degustates"
, cond = Any ( Pre "any of:" ) [ Leaf "eats", Leaf "drinks" ]
, cond = Just $ Any ( Pre "any of:" ) [ Leaf "eats", Leaf "drinks" ]
}

it "should parse a simple constitutive rule" $ do
Expand All @@ -103,18 +107,19 @@ main = hspec $ do

let imbibeRule2 = [ Regulative
{ every = "person"
, who = All
, who = Just $ All
( Pre "Who" )
[ Leaf "walks"
, Leaf "degustates"
]
, cond = Nothing
, deontic = DMust
, action = ("sing", [])
, temporal = Nothing
}
, Constitutive
{ term = "degustates"
, cond = Any ( Pre "any of:" ) [ Leaf "eats", Leaf "drinks" ]
, cond = Just $ Any ( Pre "any of:" ) [ Leaf "eats", Leaf "drinks" ]
}
]

Expand Down

0 comments on commit 3dcfe1a

Please sign in to comment.