added the new binary operator concept to exponentiation

Author: L0neGamer

src/Tablebot/Plugins/Roll/Dice/DiceData.hs

@@ -118,9 +118,15 @@ data Negation = Neg Expo | NoNeg Expo
   deriving (Show)
 
 -- | The type representing a value with exponentials.
-data Expo = Expo Func Expo | NoExpo Func
+newtype Expo = Expo (BinOp Func ExpoType)
   deriving (Show)
 
+data ExpoType = Expo'
+  deriving (Show)
+
+instance Operation ExpoType where
+  getOperation _ = (^)
+
 -- | The type representing a single function application, or a base item.
 data Func = Func FuncInfo [ArgValue] | NoFunc Base
   deriving (Show)
@@ -224,7 +230,7 @@ instance (Converter a Expo) => Converter a Negation where
   promote = NoNeg . promote
 
 instance (Converter a Func) => Converter a Expo where
-  promote = NoExpo . promote
+  promote = Expo . promote
 
 instance (Converter a Base) => Converter a Func where
   promote = NoFunc . promote

src/Tablebot/Plugins/Roll/Dice/DiceEval.hs

@@ -436,14 +436,14 @@ instance IOEval Negation where
     return (negate expo', "-" <> expo's)
 
 instance IOEval Expo where
-  evalShow' (NoExpo b) = evalShow b
-  evalShow' (Expo b expo) = do
-    (expo', expo's) <- evalShow expo
-    if expo' < 0
-      then evaluationException ("the exponent is negative: " <> formatInput Code expo') [parseShow expo]
-      else do
-        (b', b's) <- evalShow b
-        return (b' ^ expo', b's <> " ^ " <> expo's)
+  evalShow' (Expo (BinOp a tas)) = foldl' foldel (evalShow a) tas
+    where
+      foldel at (typ, b) = do
+        (a', t) <- at
+        (b', t') <- evalShow b
+        if b' == 0
+          then evaluationException ("the exponent is negative: " <> formatInput Code t') [parseShow b]
+          else return (getOperation typ a' b', t <> " " <> parseShow typ <> " " <> t')
 
 instance IOEval NumBase where
   evalShow' (NBParen (Paren e)) = do

src/Tablebot/Plugins/Roll/Dice/DiceParsing.hs

@@ -110,10 +110,6 @@ instance CanParse ListValuesBase where
       unnest (Paren (LVBase (LVBParen e))) = e
       unnest e = e
 
--- | Helper function to try to parse the second part of a binary operator.
-binOpParseHelp :: (CanParse a) => Char -> (a -> a) -> Parser a
-binOpParseHelp c con = try (skipSpace *> char c) *> skipSpace *> (con <$> pars)
-
 instance (CanParse b) => CanParse (If b) where
   pars = do
     a <- string "if" *> skipSpace1 *> pars <* skipSpace1
@@ -171,16 +167,17 @@ instance CanParse Negation where
       <|> NoNeg <$> pars
 
 instance CanParse Expo where
-  pars = do
-    t <- pars
-    binOpParseHelp '^' (Expo t) <|> (return . NoExpo) t
+  pars = Expo <$> pars
+
+instance CanParse ExpoType where
+  pars = try (char '^' $> Expo')
 
 instance CanParse NumBase where
   pars =
     (NBParen . unnest <$> pars)
       <|> Value <$> integer <??> "could not parse integer"
     where
-      unnest (Paren (Expr (SingBinOp (Term (SingBinOp (NoNeg (NoExpo (NoFunc (NBase (NBParen e)))))))))) = e
+      unnest (Paren (Expr (SingBinOp (Term (SingBinOp (NoNeg (Expo (SingBinOp (NoFunc (NBase (NBParen e))))))))))) = e
       unnest e = e
 
 instance (CanParse a) => CanParse (Paren a) where
@@ -285,7 +282,7 @@ instance ParseShow ArgValue where
 instance ParseShow ListValues where
   parseShow (LVBase e) = parseShow e
   parseShow (MultipleValues nb b) = parseShow nb <> "#" <> parseShow b
-  parseShow (LVFunc s n) = funcInfoName s <> "(" <> T.intercalate "," (parseShow <$> n) <> ")"
+  parseShow (LVFunc s n) = funcInfoName s <> "(" <> T.intercalate ", " (parseShow <$> n) <> ")"
   parseShow (LVVar t) = t
   parseShow (ListValuesMisc l) = parseShow l
 
@@ -304,14 +301,14 @@ instance ParseShow ExprType where
   parseShow Add = "+"
   parseShow Sub = "-"
 
-instance ParseShow TermType where
-  parseShow Multi = "*"
-  parseShow Div = "/"
-
 instance ParseShow Expr where
   parseShow (Expr e) = parseShow e
   parseShow (ExprMisc e) = parseShow e
 
+instance ParseShow TermType where
+  parseShow Multi = "*"
+  parseShow Div = "/"
+
 instance ParseShow Term where
   parseShow (Term f) = parseShow f
 
@@ -323,9 +320,11 @@ instance ParseShow Negation where
   parseShow (Neg expo) = "-" <> parseShow expo
   parseShow (NoNeg expo) = parseShow expo
 
+instance ParseShow ExpoType where
+  parseShow _ = "^"
+
 instance ParseShow Expo where
-  parseShow (NoExpo b) = parseShow b
-  parseShow (Expo b expo) = parseShow b <> " ^ " <> parseShow expo
+  parseShow (Expo e) = parseShow e
 
 instance ParseShow NumBase where
   parseShow (NBParen p) = parseShow p

src/Tablebot/Plugins/Roll/Dice/DiceStats.hs

@@ -136,12 +136,13 @@ instance Range Negation where
   range' (NoNeg t) = range t
 
 instance Range Expo where
-  range' (NoExpo t) = range t
-  range' (Expo t e) = do
-    d <- range t
-    d' <- range e
-    -- if the exponent is always negative, the distribution will be empty
-    return $ (^) <$> d <*> from (assuming (>= 0) (run d'))
+  range' (Expo (BinOp a tas)) = foldl' foldel (range a) tas
+    where
+      foldel at (typ, b) = do
+        a' <- at
+        b' <- range b
+        -- if the exponent is always negative, the distribution will be empty
+        return $ getOperation typ <$> a' <*> from (assuming (>= 0) (run b'))
 
 instance Range Func where
   range' (NoFunc t) = range t