FloatVal, average, Context, evalTableExpression, return tables from api

3 files changed, 164 insertions, 42 deletions

diff --git a/src/BizExpr.hs b/src/BizExpr.hs
index 0ccfcd3..1026e47 100644
--- a/src/BizExpr.hs
+++ b/src/BizExpr.hs
@@ -1,19 +1,23 @@
 {-# LANGUAGE FlexibleInstances #-}
 
-module BizExpr (repl, eval) where
+module BizExpr (repl, eval, Context) where
 
 import Data.Maybe (fromMaybe)
 import Text.Read (readMaybe)
+import qualified Data.Text.Lazy as L
+import qualified Data.Map as M
 
+
+type Context = M.Map L.Text L.Text
 --import Data.Text as T
 
 repl :: IO ()
-repl = getLine >>= putStrLn . maybe "Failed to evaluate expression" show . (eval :: String -> Maybe Integer) >> repl
+repl = getLine >>= putStrLn . maybe "Failed to evaluate expression" show . (eval M.empty :: String -> Maybe Integer) >> repl
 
-eval :: CoerceTo a => String -> Maybe a
-eval x = coerceTo =<< evalAst . head . fst =<< parseLevel x
+eval :: CoerceTo a => Context -> String -> Maybe a
+eval c x = coerceTo =<< evalAst . head . fst =<< parseLevel c x
 
-data Value = IntVal Integer | StrVal String | BoolVal Bool
+data Value = IntVal Integer | StrVal String | BoolVal Bool | FloatVal Float
   deriving (Show)
 
 class CoerceTo a where
@@ -21,17 +25,25 @@ class CoerceTo a where
   coerceFrom :: a -> Value
 
 instance CoerceTo Integer where
+  coerceTo (FloatVal n) = Just $ floor n
   coerceTo (IntVal n) = Just n
+  coerceTo v = coerceTo . FloatVal =<< coerceTo v
+  coerceFrom = IntVal
+
+instance CoerceTo Float where
+  coerceTo (FloatVal n) = Just n
+  coerceTo (IntVal n) = Just $ fromIntegral n
   coerceTo (StrVal s) = readMaybe s
   coerceTo (BoolVal True) = Just 1
   coerceTo (BoolVal False) = Just 0
 
-  coerceFrom = IntVal
+  coerceFrom = FloatVal
 
 instance CoerceTo String where
   coerceTo (BoolVal v) = Just $ show v
   coerceTo (IntVal v) = Just $ show v
   coerceTo (StrVal v) = Just v
+  coerceTo (FloatVal v) = Just $ show v
   coerceFrom = StrVal
 
 instance CoerceTo Bool where
@@ -50,12 +62,12 @@ data Ast
   | Val Value
   deriving (Show)
 
-parseLevel :: String -> Maybe ([Ast], String)
-parseLevel = go "" (Just [])
+parseLevel :: Context -> String -> Maybe ([Ast], String)
+parseLevel c = go "" (Just [])
   where
     go :: String -> Maybe [Ast] -> String -> Maybe ([Ast], String)
     go prev (Just l) ('(' : next) =
-      case parseLevel next of
+      case parseLevel c next of
         Nothing ->
           Nothing
         Just (arg, remnant) ->
@@ -65,18 +77,23 @@ parseLevel = go "" (Just [])
                   else remnant
            in go "" (Just (l ++ [Expr prev arg])) r
     go prev (Just l) (')' : remnant) =
-      let l0 = [Val $ StrVal prev | prev /= ""]
+      let l0 = [Val $ newVal c prev | prev /= ""]
        in Just (l ++ l0, remnant)
     go prev (Just l) (',' : next) =
-      let l0 = [Val $ StrVal prev]
+      let l0 = [Val $ newVal c prev]
        in go "" (Just (l ++ l0)) next
     go "" (Just l) "" =
       Just (l, "")
     go prev (Just l) "" =
-      Just (l ++ [Val $ StrVal prev], "")
+      Just (l ++ [Val $ newVal c prev], "")
     go prev l (x : xs) =
       go (prev ++ [x]) l xs
 
+newVal :: Context -> String -> Value
+newVal c x = case M.lookup (L.pack x) c of
+  Nothing -> StrVal x
+  Just n -> StrVal $ L.unpack n
+
 evalAst :: Ast -> Maybe Value
 evalAst (Expr name ast) = fromMaybe Nothing (getFunc name <*> evalLevel ast)
 evalAst (Val val) = Just val
@@ -88,10 +105,11 @@ getFunc :: String -> Maybe ([Value] -> Maybe Value)
 getFunc "sum" = Just eSum
 getFunc "any" = Just eAny
 getFunc "all" = Just eAll
+getFunc "average" = Just eAverage
 getFunc _ = Nothing
 
 eSum :: [Value] -> Maybe Value
-eSum = eFold (+) (0 :: Integer)
+eSum = eFold (+) (0.0 :: Float)
 
 eAny :: [Value] -> Maybe Value
 eAny = eFold (||) False
@@ -99,6 +117,12 @@ eAny = eFold (||) False
 eAll :: [Value] -> Maybe Value
 eAll = eFold (&&) True
 
+eAverage :: [Value] -> Maybe Value
+eAverage xs = do
+  let n = coerceTo =<< eSum xs
+      d = Just . fromIntegral $ length xs
+   in FloatVal <$> ((/) <$> n <*> d)
+
 eFold :: (CoerceTo a, CoerceTo b) => (b -> a -> b) -> b -> [Value] -> Maybe Value
 eFold fn init [] = Just $ coerceFrom init
 eFold fn init (x : xs) =
diff --git a/src/MyLib.hs b/src/MyLib.hs
index 864f99e..c8dc95d 100644
--- a/src/MyLib.hs
+++ b/src/MyLib.hs
@@ -31,13 +31,7 @@ instance CoerceTo Bool where
   coerceTo (IntVal v) = Just $ v /= 0
   coerceTo (StrVal "True") = Just True
   coerceTo (StrVal "true") = Just True
-  --coerceTo v@(StrVal _) = coerceTo . IntVal =<< (coerceTo v :: Maybe Integer) :: Maybe Bool
-  coerceTo v@(StrVal x) = case (readMaybe x :: Maybe Integer) of
-      Nothing -> Just False
-      Just n -> Just $ True--n /= 0
---    case coerceTo v :: Maybe Integer of
---      Nothing -> Just False
---      Just n -> coerceTo (IntVal n)
+  coerceTo v = coerceTo . IntVal =<< (coerceTo v :: Maybe Integer) :: Maybe Bool
 
   coerceFrom = BoolVal
 
diff --git a/src/RestService.hs b/src/RestService.hs
index 2921687..cb62423 100644
--- a/src/RestService.hs
+++ b/src/RestService.hs
@@ -1,57 +1,161 @@
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE LambdaCase #-}
-module RestService (start) where
+{-# LANGUAGE OverloadedStrings #-}
 
-import Network.HTTP.Types.URI
-import Network.Wai
-import Network.Wai.Handler.Warp
-import Data.Aeson (FromJSON, ToJSON)
-import Web.Scotty as S
-import Data.Maybe (fromMaybe)
-import GHC.Generics
+module RestService (start) where
 
+import qualified BizExpr as E
 import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Concurrent.STM.TArray
-
-import qualified BizExpr as E
-import qualified Data.Text.Lazy as L
-import qualified Data.Text as T
+import Data.Aeson (FromJSON, ToJSON)
+import qualified Data.IntMap as IM
 import qualified Data.Map as M
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as L
+import GHC.Generics
 import qualified Network.HTTP.Types.Status as Status
+import Network.HTTP.Types.URI
+import Network.Wai
+import Network.Wai.Handler.Warp
+import Web.Scotty as S
+
+addHeaders :: Middleware
+addHeaders =
+  modifyResponse
+    ( mapResponseHeaders
+        ( [ ("Access-Control-Allow-Methods ", "GET, POST"),
+            ("Access-Control-Allow-Headers", "Content-Type"),
+            ("Access-Control-Allow-Origin", "*")
+          ]
+            ++
+        )
+    )
 
 staticFilePaths :: [FilePath]
 staticFilePaths = map ("./static/" ++) ["materialize.min.css", "materialize.min.js", "service.js"]
 
 staticFiles :: ScottyM ()
 staticFiles = do
-  --    get "/static/:file" $ file
   mapM_ addFile staticFilePaths
   where
     addFile path = get (capture $ tail path) $ file path
 
 data ExprReq = ExprReq {expression :: L.Text, result :: Maybe L.Text}
-    deriving (Show, Generic)
+  deriving (Show, Generic)
+
 instance FromJSON ExprReq
 
-numInc :: State -> IO Int
-numInc s = atomically (readTVar s >>= writeTVar s . (+1) >> readTVar s)
+instance ToJSON ExprReq
+
+--numInc :: State -> IO Table
+--numInc s = atomically $ (\x -> writeTVar s x >> return x) . () =<< readTVar s
+
+getTable :: State -> Int -> IO (Maybe Table)
+getTable s n = atomically $ IM.lookup n <$> readTVar s
+
+setTable :: State -> Int -> Table -> IO (Maybe Table)
+setTable s n t = atomically $ (\x -> writeTVar s x >> return (Just t)) . IM.insert n t =<< readTVar s
 
 routes :: State -> ScottyM ()
 routes state = do
+  S.middleware addHeaders
   staticFiles
-  get "/num" $
-    S.json =<< liftAndCatchIO (numInc state)
+  get "/t/dummy" $
+    S.json $ evalTableExpressions (TableExpressions dummyTable ["sum(2,3,5)", "any(0,0,1)", "sum(age, -10)", "any(0,1)"])
+  get "/t/:id" $
+    S.json =<< liftAndCatchIO . getTable state =<< S.param "id"
+  post "/t/:id" $ do
+    id <- S.param "id"
+    S.json =<< liftAndCatchIO . setTable state id =<< S.jsonData
   get "/:expr" $
     S.text =<< S.param "expr"
   post "/eval" $
-    S.text . L.pack . fromMaybe "failure" . E.eval . L.unpack . expression =<< S.jsonData
+    S.json . (ExprReq <*> eval M.empty) . expression =<< S.jsonData
+
+eval :: E.Context -> L.Text -> Maybe L.Text
+eval c = fmap L.pack . E.eval c . L.unpack
+
+type TableHeading = L.Text
+
+type TableRow = M.Map TableHeading TableCell
+
+type TableCell = L.Text
+
+type Tables = IM.IntMap Table
+
+type Expression = L.Text
+
+data TableExpressions = TableExpressions
+  { table :: Table,
+    expressions :: [Expression]
+  }
+  deriving (Show, Generic)
+
+evalTableExpressions :: TableExpressions -> Table
+evalTableExpressions (TableExpressions table expressions) =
+  foldl applyExpression table expressions
+
+applyExpression :: Table -> Expression -> Table
+applyExpression table expr =
+  table
+    { table_headings = table_headings table ++ [expr],
+      table_rows =
+        map
+          ( \row ->
+              M.insert
+                expr
+                ( fromMaybe "-" (eval row expr)
+                )
+                row
+          )
+          (table_rows table)
+    }
+
+data Table = Table
+  { table_name :: L.Text,
+    table_headings :: [TableHeading],
+    table_rows :: [TableRow]
+  }
+  deriving (Show, Generic)
+
+instance FromJSON Table
+
+instance ToJSON Table
+
+type State = TVar Tables
+
+dummyTable =
+  Table
+    { table_name = "dummy table",
+      table_headings = ["name", "age", "height"],
+      table_rows =
+        [ M.fromList
+            [ ("name", "alice"),
+              ("age", "30")
+            ],
+          M.fromList
+            [ ("name", "bob"),
+              ("age", "40")
+            ],
+          M.fromList
+            [ ("name", "charles"),
+              ("height", "1.80")
+            ]
+        ]
+    }
+
+addRow :: Table -> TableRow -> Table
+addRow t tr = t {table_rows = tr0 : table_rows t}
+  where
+    tr0 = M.filterWithKey (\k _ -> k `elem` table_headings t) tr
 
-type State = TVar Int
+stateInit :: IO State
+stateInit = newTVarIO $ IM.fromList [(-1, dummyTable)]
 
 start :: IO ()
-start = scottyOpts opts . routes =<< newTVarIO 3
+start = scottyOpts opts . routes =<< stateInit
 
 opts :: Options
 opts = Options 1 settings