WIP, refactoring in progress, everything is probably badly broken

mengwong/mp/mp.cabal

@@ -40,10 +40,12 @@ library
     , bytestring
     , cassava
     , containers
+    , generic-data
     , hspec
     , hspec-megaparsec
     , megaparsec
     , mtl
+    , parsers
     , pretty-simple
     , split
     , text
@@ -64,11 +66,13 @@ executable mp-exe
     , bytestring
     , cassava
     , containers
+    , generic-data
     , hspec
     , hspec-megaparsec
     , megaparsec
     , mp
     , mtl
+    , parsers
     , pretty-simple
     , split
     , text
@@ -90,11 +94,13 @@ test-suite mp-test
     , bytestring
     , cassava
     , containers
+    , generic-data
     , hspec
     , hspec-megaparsec
     , megaparsec
     , mp
     , mtl
+    , parsers
     , pretty-simple
     , split
     , text

mengwong/mp/package.yaml

@@ -34,6 +34,8 @@ dependencies:
 - boxes
 - anyall
 - split
+- generic-data
+- parsers
 
 library:
   source-dirs: src

mengwong/mp/src/Lib.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE LambdaCase        #-}
@@ -14,6 +16,7 @@ import qualified Data.Set           as Set
 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)
@@ -26,12 +29,10 @@ import           Text.PrettyPrint.Boxes hiding ((<>))
 import System.Environment (lookupEnv)
 import qualified Data.ByteString.Lazy as BS
 import qualified Data.List.Split as DLS
+import Text.Parser.Permutation
 
 import Debug.Trace
 
--- import qualified Debug.Trace as Debug
--- import Data.Function
-
 import Types
 import Error
 
@@ -62,7 +63,7 @@ runExample rc str = forM_ (exampleStreams str) $ \stream ->
       -- Left bundle -> putStr (errorBundlePretty bundle)
       -- Left bundle -> pPrint bundle
       Right xs -> pPrint xs
-  
+
 exampleStream :: ByteString -> MyStream
 exampleStream s = case getStanzas (asCSV s) of
                     Left errstr -> error errstr
@@ -133,16 +134,16 @@ getChunks loc@(Location rs (cx,cy) ((lx,ly),(rx,ry))) =
   let listChunks = DLS.splitWhen (\i -> V.all Text.null $ rs ! i) [ 0 .. ry ]
       wantedChunks = [ rows
                      | rows <- listChunks
-                     , any (\row -> 
+                     , any (\row ->
                                any (\w -> w `elem` Text.words "EVERY MUST MAY WHEN MEANS IS IF UNLESS")
                                (V.toList (rs ! row)))
                        rows
                      ]
       toreturn = setRange loc <$> wantedChunks
-  in trace ("getChunks: input = " ++ show [ 0 .. ry ])
-     trace ("getChunks: listChunks = " ++ show listChunks)
-     trace ("getChunks: wantedChunks = " ++ show wantedChunks)
-     trace ("getChunks: returning " ++ show (length toreturn) ++ " stanzas: " ++ show toreturn)
+  in -- trace ("getChunks: input = " ++ show [ 0 .. ry ])
+     -- trace ("getChunks: listChunks = " ++ show listChunks)
+     -- trace ("getChunks: wantedChunks = " ++ show wantedChunks)
+     -- trace ("getChunks: returning " ++ show (length toreturn) ++ " stanzas: " ++ show toreturn)
      toreturn
 
 -- is the cursor on a line that has nothing in it?
@@ -151,16 +152,16 @@ blankLine loc = all Text.null $ currentLine loc
 
 extractRange :: Location -> RawStanza
 extractRange (Location rawStanza cursor xy@((lx,ly),(rx,ry))) =
-  let slicey = trace ("extractRange: given rawStanza " ++ show rawStanza)
-               trace ("extractRange: trying to slice " ++ show xy)
-               trace ("extractRange: trying to slice y " ++ show (ly, ry-ly+1))
+  let slicey = -- trace ("extractRange: given rawStanza " ++ show rawStanza)
+               -- trace ("extractRange: trying to slice " ++ show xy)
+               -- trace ("extractRange: trying to slice y " ++ show (ly, ry-ly+1))
                V.slice ly (ry-ly+1) rawStanza
-      slicex = trace ("extractRange: got slice y " ++ show slicey)
-               trace ("extractRange: trying to slice x " ++ show (lx, rx-lx+1))
+      slicex = -- trace ("extractRange: got slice y " ++ show slicey)
+               -- trace ("extractRange: trying to slice x " ++ show (lx, rx-lx+1))
                V.slice lx (rx-lx+1) <$> slicey
-  in trace ("extractRange: got slice x " ++ show slicex)
+  in -- trace ("extractRange: got slice x " ++ show slicex)
      slicex
-      
+
 setRange :: Location -> [Int] -> Location
 setRange loc@(Location rawStanza c ((lx,ly),(rx,ry))) ys =
   let cursorToEndLine  = moveTo loc (1,       last ys)
@@ -291,27 +292,95 @@ pConstitutiveRule depth = do
   myTraceM $ "pConstitutiveRule: returning " ++ show toreturn
   return toreturn
 
-pRegRule :: Depth -> Parser [Rule]
-pRegRule depth = do
+pRegRule = try pRegRuleSugary <|> pRegRuleNormal
+
+-- "You MAY" has no explicit PARTY or EVERY keyword
+pRegRuleSugary :: Depth -> Parser [Rule]
+pRegRuleSugary depth = do
+  entitytype         <- pOtherVal <* dnl
   leftX              <- lookAhead pXLocation -- this is the column where we expect IF/AND/OR etc.
-  guard $ leftX >= depth
-  entitytype         <- pToken Every *> many pEmpty *> pOtherVal <* dnl
-  pbr                <- optional (preambleBoolRules leftX)                      <* dnl
-  deontic            <- pDeontic                                                <* dnl
-  temporal           <- listToMaybe <$> many pOtherVal                          <* dnl
-  action             <- pToken Do *> many pEmpty *> (Text.unwords <$> many pOtherVal)          <* dnl
+  deontic            <- pDeontic <* dnl
+  temporal           <- optional pTemporal
+  (pbrs, action)     <- permutations depth
   let (who, (ands, brs)) = fromMaybe (Always, (AA.Any (AA.Pre "always") [], [])) pbr -- if there is no WHO line
       toreturn = Regulative entitytype (newPre (Text.pack $ show who) ands) deontic action temporal
   myTraceM $ "pRegRule: the specifier is " ++ show who
   myTraceM $ "pRegRule: returning " ++ show toreturn
   return ( toreturn : brs )
+
+pRegRuleNormal :: Depth -> Parser [Rule]
+pRegRuleNormal = do
+  leftX              <- lookAhead pXLocation -- this is the column where we expect IF/AND/OR etc.
+  guard $ leftX >= depth
+  entitytype         <- pActor Party <|> pActor Every
+  (ewho, (ebs, ebrs))         <- mergePBRS <$> many (preambleBoolRules leftX)               <* dnl
+  -- the below are going to be permutables
+  rulebody <- permutations
+  -- deontic            <- pDeontic                                                <* dnl
+  -- temporal           <- optional pTemporal
+  -- action             <- pAction
+  let (who, (cbs, brs)) = mergePBRS $ pbrs rulebody
+  let toreturn = Regulative entitytype (newPre (Text.pack $ show ewho) ebs) cbs deontic action temporal
+  myTraceM $ "pRegRule: the specifier is " ++ show who
+  myTraceM $ "pRegRule: returning " ++ show toreturn
+  return ( toreturn : brs )
+  where
+    mergePBRS xs =
+      let (w,(a,b)) = head xs
+          pre_a = fst <$> tail xs
+      in (w,( a : mconcat pre_a
+            ,     concat (b ++ (snd <$> tail xs)) ) )
+
+
+pTemporal = do
+  t1 <- pToken Before <|> pToken After <|> pToken By <* dnl
+  t2 <- pOtherVal                                    <* dnl
+  return $ mkTC t1 t2
+
+-- "PARTY Seller"
+-- "EVERY Seller"
+pActor :: MyToken -> Parser (MyToken, Text.Text)
+pActor party = do
+  entitytype         <- pToken party *> many pEmpty *> pOtherVal <* dnl
+  return (party, entitytype)
+
+pAction :: Depth -> Parser (Text.Text, [(Text.Text, Text.Text)])
+pAction depth = do
+  action <- pToken Do *> many pEmpty *> pOtherVal          <* dnl
+  params <- many (pOtherVal <* dnl) -- it'd be nice to have newline detection
+  return (action, list2tuples)
   where
-    newPre :: Text.Text -> AA.Item Text.Text -> AA.Item Text.Text
-    newPre t (AA.Leaf x) = AA.Leaf x
-    newPre t (AA.All (AA.Pre     p)    x) = AA.All (AA.Pre     t   ) x
-    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
+    list2tuples :: Monoid a => [a] -> [(a,a)]
+    list2tuples [] = []
+    list2tuples (x:y:z) = (x,y)      : list2tuples z
+    list2tuples [x]  = [(x,mempty)]
+
+-- we create a permutation parser returning one or more RuleBodies, which we treat as monoidal,
+-- though later we may object if there is more than one.
+
+data RuleBody :: RuleBody { pbrs    :: [(Preamble, BoolRules)] -- not subject to the party
+                          , action  :: [(Text.Text,[(Text.Text,Text.Text)])] -- pay(to=Seller, amount=$100)
+                          , deontic :: [Deontic]
+                          , temporal :: [TemporalConstraint Text.Text]
+                          }
+                      deriving (Ord, Eq, Show, Read, Generic)
+                      deriving (Semigroup, Monoid) via Generically RuleBody
+
+permutations :: Depth -> Parser RuleBody
+permutations depth =
+  permute (mconcat
+           <$$> ((\a -> RuleBody [] [a] [] []) <$> pAction)
+           <|?> ( RuleBody [(Always, AA.Any (AA.Pre "always"))] , \a -> RuleBody a [] [] [] <$> many (preambleBoolRules leftX) <* dnl ) -- WHO xxx, IF yyy
+           <|?> ( RuleBody [] [] [] [] , \a -> RuleBody [] [] [a] [] <$> pDeontic )
+           <|?> ( RuleBody [] [] [] [] , \a -> RuleBody [] [] [] [a] <$> pTemporal )
+          )
+
+newPre :: Text.Text -> AA.Item Text.Text -> AA.Item Text.Text
+newPre t (AA.Leaf x) = AA.Leaf x
+newPre t (AA.All (AA.Pre     p)    x) = AA.All (AA.Pre     t   ) x
+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

mengwong/mp/src/Types.hs

@@ -24,25 +24,37 @@ type BoolRules = (BoolStruct, [Rule])
 
 data Rule = Regulative
             { every    :: EntityType         -- every person
-            , who      :: BoolStruct         -- walks and (eats or drinks)
+            , who      :: BoolStruct         -- who walks and (eats or drinks)
+            , cond     :: BoolStruct         -- if it is a saturday
             , deontic  :: Deontic            -- must
             , action   :: ActionType         -- sing
-            , temporal :: Maybe TemporalConstraint -- before midnight
+            , temporal :: Maybe (TemporalConstraint Text.Text) -- Before "midnight"
             }
           | Constitutive
             { term :: ConstitutiveTerm
             , cond :: BoolStruct
             }
           deriving (Eq, Show)
 -- everything is stringly typed at the moment but as this code matures these will become more specialized.
-type TemporalConstraint = Text.Text
+data TemporalConstraint a = TBefore a
+                          | TAfter  a
+                          | TBy     a
+                          | TOn     a
+                          deriving (Eq, Show)
 type ConstitutiveTerm = Text.Text
 type EntityType = Text.Text
 type ActionType = Text.Text
 type BoolStruct = AA.Item Text.Text
 data Deontic = DMust | DMay | DShant
   deriving (Eq, Show)
 
+mkTC :: MyToken -> MyToken -> TemporalConstraint Text.Text
+mkTC Before (Other tt) = TBefore tt
+mkTC After  (Other tt) = TAfter  tt
+mkTC By     (Other tt) = TBy     tt
+mkTC On     (Other tt) = TOn     tt
+mkTC x      y          = error $ "mkTC: can't create temporal constraint from " ++ show x ++ ", " ++ show y
+
 data RunConfig = RC { debug     :: Bool
                     , callDepth :: Int
                     }
@@ -53,6 +65,7 @@ toToken :: Text.Text -> MyToken
 
 -- start a regulative rule
 toToken "EVERY" =  Every
+toToken "PARTY" =  Party
 
 -- start a boolstruct
 toToken "ALWAYS" = Always
@@ -72,8 +85,14 @@ toToken "MUST" =   Must
 toToken "MAY" =    May
 toToken "SHANT" =  Shant
 
+-- deontics
+toToken "BEFORE" = Before
+toToken "AFTER" =  After
+toToken "BY" =  By
+toToken "ON" =  On
+
 -- the rest of the regulative rule
-toToken "➔"       =      Do
+toToken "➔"       =     Do
 toToken "->"      =     Do
 toToken "DO"      =     Do
 toToken "PERFORM" =     Do
@@ -89,8 +108,9 @@ toToken s | [(n,"")] <- reads $ Text.unpack s = Number n
 -- any other value becomes an Other -- "walks", "runs", "eats", "drinks"
 toToken x = Other x
 
-data MyToken = Every | Who | Means | When | Is | Always
+data MyToken = Every | Party | Who | Means | When | Is | Always
              | Must | May | Shant | If | Or | And
+             | Before | After | By | On
              | Unless
              | Number Int
              | Other Text.Text