Browse Source

Adding CSV support

main
Gil Mizrahi 10 months ago
parent
commit
dcb48bbe69
18 changed files with 260 additions and 47 deletions
  1. +1
    -1
      app/Main.hs
  2. +6
    -0
      logi.cabal
  3. +1
    -0
      package.yaml
  4. +1
    -0
      src/Language/Logi.hs
  5. +2
    -0
      src/Language/Logi/Ast.hs
  6. +70
    -0
      src/Language/Logi/Csv.hs
  7. +4
    -4
      src/Language/Logi/EDSL.hs
  8. +6
    -0
      src/Language/Logi/Error.hs
  9. +46
    -18
      src/Language/Logi/Interpreter.hs
  10. +13
    -0
      src/Language/Logi/Parser.hs
  11. +4
    -0
      src/Language/Logi/Pretty.hs
  12. +37
    -6
      src/Language/Logi/Run.hs
  13. +2
    -2
      test/Aggregates.hs
  14. +30
    -0
      test/Csv.hs
  15. +2
    -2
      test/EDSL.hs
  16. +8
    -8
      test/Functions.hs
  17. +2
    -0
      test/Test.hs
  18. +25
    -6
      test/Utils.hs

+ 1
- 1
app/Main.hs View File

@@ -45,7 +45,7 @@ cmd input = do
rctx@(Ctx knowledge seed) <- get
ctx' <- liftIO $ timeout (3_000_000) $
case exec seed knowledge "repl" input of
execIO readCsvFiles seed knowledge "repl" input >>= \case
Left err -> do
putTextLn $ "*** Error: " <> ppErr err
pure rctx


+ 6
- 0
logi.cabal View File

@@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: 02b6e59237465fbb06539eae5317fa8592c7e42863f9cda4fd7c4a3fc625b72b

name: logi
version: 0.1.0
@@ -21,6 +21,7 @@ library
exposed-modules:
Language.Logi
Language.Logi.Ast
Language.Logi.Csv
Language.Logi.EDSL
Language.Logi.Error
Language.Logi.Interpreter
@@ -37,6 +38,7 @@ library
, bytestring
, cereal
, containers
, csv
, deepseq
, groom
, lens
@@ -65,6 +67,7 @@ executable logi-repl
, bytestring
, cereal
, containers
, csv
, deepseq
, groom
, lens
@@ -88,6 +91,7 @@ test-suite test
main-is: Test.hs
other-modules:
Aggregates
Csv
EDSL
Functions
Query
@@ -102,6 +106,7 @@ test-suite test
, bytestring
, cereal
, containers
, csv
, deepseq
, groom
, hspec


+ 1
- 0
package.yaml View File

@@ -27,6 +27,7 @@ dependencies:
- uniplate
- regex-tdfa
- prettyprinter
- csv


library:


+ 1
- 0
src/Language/Logi.hs View File

@@ -9,4 +9,5 @@ import Language.Logi.Parser as Export
import Language.Logi.Pretty as Export
import Language.Logi.Interpreter as Export
import Language.Logi.EDSL as Export
import Language.Logi.Csv as Export
import Language.Logi.Run as Export

+ 2
- 0
src/Language/Logi/Ast.hs View File

@@ -91,11 +91,13 @@ data Statement
| Query !Atom
| Expr !Expr
| FunDef Name Fun
| ExternalDef Name FilePath
deriving (Show, Eq, Ord, Data, Typeable, Generic, NFData)

data Knowledge
= Knowledge
{ _functions :: Map Name Fun
, _externals :: Map Name FilePath
, _rules :: Map Name (Set Rule)
, _varSeed :: Integer
}


+ 70
- 0
src/Language/Logi/Csv.hs View File

@@ -0,0 +1,70 @@
{-# language BlockArguments #-}
{-# language TemplateHaskell #-}

module Language.Logi.Csv where

import Relude

import Text.Megaparsec hiding (ErrorItem(..), label)
import qualified Text.Megaparsec.Char as P
import qualified Text.Megaparsec.Char.Lexer as L
import Control.Monad.Except
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.Text as T
import Text.CSV (CSV, parseCSV)

import Language.Logi.Ast
import Language.Logi.Error
import Language.Logi.Parser


parseCsvFile :: MonadError Err m => Name -> Text -> m (Set Atom)
parseCsvFile name@(Name nm) txt = do
case parseCSV (toString nm) (toString txt) of
Left err -> throwError $ CsvParseError (show err)
Right [] -> do
pure mempty
Right (header:rows) -> do
csv <- parseCsv header rows
pure $ S.fromList $ map (Atom name) csv

parseCsv :: MonadError Err m => [String] -> CSV -> m [Expr]
parseCsv header =
mapM (pure . ERecord . M.fromList <=< parseRow header)

parseRow :: MonadError Err m => [String] -> [String] -> m [(Label, Expr)]
parseRow header row =
zipWithM
( \fieldname (toText -> field) -> do
field' <- parseField fieldname field
pure (Label (toText fieldname), ELit field')
)
header
row

parseField :: MonadError Err m => String -> Text -> m Lit
parseField fieldname field = do
let
parser =
lexeme $ choice
[ (LitString <$> string)
, try (parseLit <* eof)
, pure (LitString $ (T.unwords . T.words) field)
]
case runParser parser fieldname field of
Left err -> throwError (CsvParseError (show err))
Right x -> pure x

string = fmap toText $ P.char '\"' *> manyTill L.charLiteral (P.char '\"')

-- I want to get some analytics about visits to my website using my proglang

test :: IO ()
test = do
v <- readFileText "/home/suppi/visits.csv"
let p = runExcept $ parseCsvFile (Name "visits") visits
visits = T.unlines $ take 10 $ T.lines v
case p of
Left err -> putTextLn $ ppErr err
Right x -> putTextLn $ show x

+ 4
- 4
src/Language/Logi/EDSL.hs View File

@@ -157,8 +157,8 @@ greater_equal_ e1 e2 = EApp (N $ Name "greater_equal") [e1, e2]
concat_ :: [Expr] -> Expr
concat_ = EApp (N $ Name "concat")

size_ :: Expr -> Expr
size_ expr = EApp (N $ Name "size") [expr]
count_ :: Expr -> Expr
count_ expr = EApp (N $ Name "count") [expr]

-- ** Numbers

@@ -185,8 +185,8 @@ aavg_ :: Text -> Expr
aavg_ rel = EApp (N $ Name "aavg") [ERel $ Name rel]

-- | Number of elements in a relation.
asize_ :: Text -> Expr
asize_ rel = EApp (N $ Name "asize") [ERel $ Name rel]
acount_ :: Text -> Expr
acount_ rel = EApp (N $ Name "acount") [ERel $ Name rel]

-- | Fold a function over a relation
afold_ :: Text -> Expr -> Text -> Expr


+ 6
- 0
src/Language/Logi/Error.hs View File

@@ -20,7 +20,9 @@ data Err
| ExprWithFreeVar Expr (Map Var Expr) Var
| ExprWithoutLabel Expr Label
| ParseError (ParseErrorBundle Text Void)
| CsvParseError Text
| MutualRecursion Name Name
| IOError Text
| InternalError Text
| Timeout
deriving (Show, Eq, Data, Typeable, Generic, NFData)
@@ -53,6 +55,8 @@ ppErr = \case
"The expression " <> pp rec <> " does not contain the label " <> pp lbl <> "."
ParseError err ->
toText $ errorBundlePretty err
CsvParseError err ->
"CSV parse error in " <> err
MutualRecursion a b ->
unwords
[ "Mutual recursion is not allowed. Found between:"
@@ -67,6 +71,8 @@ ppErr = \case
, "The unbound variable: \t" <> pp var
, "Bound variables: \t" <> pp (M.keys sub)
]
IOError e ->
"IO: " <> e
Timeout ->
"Operation timed out."
InternalError e ->


+ 46
- 18
src/Language/Logi/Interpreter.hs View File

@@ -5,13 +5,14 @@ module Language.Logi.Interpreter where

import Relude

import Control.Monad.Except (Except, MonadError, throwError, foldM)
import Control.Monad.Except (MonadError, throwError, foldM)
import qualified Data.Text as T
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.Map.Merge.Strict as M
import Control.Lens hiding ((.=), transformM, transform, mapping)
import qualified Data.Generics.Uniplate.Data as U
import Control.Exception (catch)
import System.Random
import Data.Ratio ((%))
import Text.Regex.TDFA ((=~))
@@ -36,23 +37,26 @@ data QueryCtx
= QueryCtx
{ _ctx :: Ctx
, _qFacts :: Set Atom
, _fileReader :: FileReader
}

type FileReader = Name -> FilePath -> IO (Set Atom)

makeLenses ''Ctx
makeLenses ''QueryCtx

type Eval a
= StateT Ctx (Except Err) a
= StateT Ctx (ExceptT Err IO) a

type QueryEval a
= StateT QueryCtx (Except Err) a
= StateT QueryCtx (ExceptT Err IO) a

------------
-- Runner --
------------

eval :: Statement -> Eval Result
eval = \case
eval :: FileReader -> Statement -> Eval Result
eval fr = \case
RuleStmt rule -> do
insertRule rule
pure Ok
@@ -67,30 +71,36 @@ eval = \case
modify $ over (ctxKnowledge . functions) (M.insert name fun)
pure Ok

ExternalDef name file -> do
modify $ over (ctxKnowledge . externals) (M.insert name file)
pure Ok

Expr (EApp (N (Name "clear_db")) []) -> do
modify $ set ctxKnowledge defaultKnowledge
pure Ok

Expr (EApp (N (Name "clear")) [ERel (Name name)]) -> do
modify $ over (ctxKnowledge . rules) $ M.delete (Name name)
modify $ over (ctxKnowledge . externals) $ M.delete (Name name)
modify $ over (ctxKnowledge . functions) $ M.delete (Name name)
pure Ok

Expr expr -> do
-- funcsmap <- M.mapWithKey (\k v -> ENoV $ N k) . view (ctxKnowledge . functions) <$> get
(expr', _) <- runQuery $ U.transformM (evalExpr' mempty) expr
(expr', _) <- runQuery fr $ U.transformM (evalExpr' mempty) expr
pure $ ExprResult expr'

Query fact ->
runQuery (evalQuery fact) >>= \case
runQuery fr (evalQuery fact) >>= \case
(res, _)
| null res -> pure No
| otherwise -> pure $ Results res

runQuery :: QueryEval a -> Eval (a, Set Atom)
runQuery m = StateT $ \context ->
runQuery :: FileReader -> QueryEval a -> Eval (a, Set Atom)
runQuery fr m = StateT $ \context ->
fmap
(\(res, QueryCtx context' facts) -> ((res, facts), context'))
(runStateT m (QueryCtx context mempty))
(\(res, QueryCtx context' facts _) -> ((res, facts), context'))
(runStateT m (QueryCtx context mempty fr))

errVars :: MonadError Err m => Var -> m Expr
errVars = throwError . FactStmtWithVars
@@ -98,6 +108,14 @@ errVars = throwError . FactStmtWithVars
errLabels :: MonadError Err m => Expr -> Label -> m Expr
errLabels expr lbl = throwError (ExprWithoutLabel expr lbl)

runIO' :: IO a -> QueryEval a
runIO' io = do
result <- liftIO $ catch
(Right <$> liftIO io)
(\(SomeException s) -> pure $ Left (show s))
case result of
Left err -> throwError (IOError err)
Right r -> pure r

insertRule :: Rule -> Eval ()
insertRule rule = do
@@ -108,7 +126,7 @@ insertRule rule = do
. (S.toList . S.fromList) -- nub
. U.universeBi
) rule
(rule', _) <- runQuery $ U.transformBiM (replaceVar newVars) rule
(rule', _) <- runQuery (const $ pure mempty) $ U.transformBiM (replaceVar newVars) rule
modify $
over (ctxKnowledge . rules) $
M.insertWith
@@ -173,6 +191,7 @@ evalRules :: Name -> QueryEval (Set Expr)
evalRules name = do
void $ checkMutualRecursion name mempty name
nameRules <- sortRules mempty . S.toList <$> getRules name
addFiles name
-- first run all of the simple rules and non recursive rules
-- Then run all of the recursive rules with the accumulated facts
-- until there are no new facts to add
@@ -391,7 +410,7 @@ fetchAtoms name = do

defaultKnowledge :: Knowledge
defaultKnowledge =
Knowledge mempty mempty 0
Knowledge mempty mempty mempty 0

newVar :: Text -> Eval Var
newVar origin = do
@@ -437,11 +456,11 @@ builtins = M.fromList
(all (x==) xs)

-- strings --
, Name "size" .= \case
, Name "count" .= \case
[ELit (LitString str)] -> do
pure $ int_ $ fromIntegral $ T.length str

args -> err (Name "size") args
args -> err (Name "count") args

, Name "concat" .= \case
args
@@ -509,12 +528,12 @@ builtins = M.fromList
args ->
err (Name "aavg") args

, Name "asize" .= \case
, Name "acount" .= \case
[ERel rel] -> do
results <- toList <$> evalRules rel
pure $ int_ $ fromIntegral $ length results
args ->
err (Name "asize") args
err (Name "acount") args

, Name "afold" .= \case
[ENoV (N fun), initial, ERel rel] -> do
@@ -578,9 +597,18 @@ comparer name comp = \case
args -> throwError $ FunTypeMismatch (Name name) args

getRules :: Name -> QueryEval (Set Rule)
getRules name =
getRules name = do
fromMaybe mempty . M.lookup name . _rules . _ctxKnowledge . _ctx <$> get

addFiles :: Name -> QueryEval ()
addFiles name = do
M.lookup name . _externals . _ctxKnowledge . _ctx <$> get >>= \case
Nothing ->
pure ()
Just file -> do
atoms <- runIO' . (\f -> f name file) . _fileReader =<< get
mapM_ addFact (S.toList atoms)

checkMutualRecursion :: Name -> Set Name -> Name -> QueryEval (Set Name)
checkMutualRecursion original acc current
| current `S.member` acc = pure acc


+ 13
- 0
src/Language/Logi/Parser.hs View File

@@ -2,10 +2,12 @@ module Language.Logi.Parser
( ParseErr
, runStmtParser
, runStmtsParser
, parseLit
, parseExpr
, parseAtom
, parseStmt
, parseStmts
, lexeme
)
where

@@ -28,6 +30,7 @@ type Parser = Parsec Void Text
reservedWords :: [Text]
reservedWords =
[ "function"
, "external"
]

spaceConsumer :: Parser ()
@@ -159,6 +162,7 @@ parseStmt :: Parser Statement
parseStmt = do
choice
[ fundef
, externaldef
, parseAtomOrExpr >>= \case
Left atom -> do
choice
@@ -183,6 +187,15 @@ fundef = do
dot
pure $ FunDef fname (Fun args body)

externaldef :: Parser Statement
externaldef = do
void $ lexeme $ P.string "external"
fname <- name <?> "external name"
equals
file <- string <?> "file path"
dot
pure $ ExternalDef fname (toString file)


parseAtom :: Parser Atom
parseAtom =


+ 4
- 0
src/Language/Logi/Pretty.hs View File

@@ -96,6 +96,10 @@ ppStmt = \case
[ "function" <+> pretty name <+> tupled (map pretty args) <+> "="
, indent 4 $ pretty body <+> "."
]
ExternalDef name path -> vsep
[ "external" <+> pretty name <+> "="
, indent 4 $ hcat ["\'", pretty path, "\'"] <+> "."
]

ppResults :: Result -> Doc ann
ppResults = \case


+ 37
- 6
src/Language/Logi/Run.hs View File

@@ -6,29 +6,60 @@ import Relude
import Control.Monad.Except

import Language.Logi.Ast
import Language.Logi.Csv
import Language.Logi.Error
import Language.Logi.Parser
import Language.Logi.Interpreter

import System.Random

-- * No IO

run :: FilePath -> Text -> Eval Result
run src txt = do
stmt <- liftEither $
either (Left . ParseError) pure (runStmtParser src txt)
eval stmt
eval (const $ pure mempty) stmt

runs :: FilePath -> Text -> Eval [Result]
runs src txt = do
stmts <- liftEither $
either (Left . ParseError) pure (runStmtsParser src txt)
traverse eval stmts
traverse (eval (const $ pure mempty)) stmts

exec :: StdGen -> Knowledge -> FilePath -> Text -> Either Err (Result, Ctx)
exec :: StdGen -> Knowledge -> FilePath -> Text -> IO (Either Err (Result, Ctx))
exec stdgen knowledge src =
runExcept . flip runStateT (Ctx knowledge stdgen) . run src
runExceptT . flip runStateT (Ctx knowledge stdgen) . run src

execs :: StdGen -> Knowledge -> FilePath -> Text -> Either Err ([Result], Ctx)
execs :: StdGen -> Knowledge -> FilePath -> Text -> IO (Either Err ([Result], Ctx))
execs stdgen knowledge src =
runExcept . flip runStateT (Ctx knowledge stdgen) . runs src
runExceptT . flip runStateT (Ctx knowledge stdgen) . runs src

-- * IO

runIO :: FileReader -> FilePath -> Text -> Eval Result
runIO fr src txt = do
stmt <- liftEither $
either (Left . ParseError) pure (runStmtParser src txt)
eval fr stmt

runsIO :: FileReader -> FilePath -> Text -> Eval [Result]
runsIO fr src txt = do
stmts <- liftEither $
either (Left . ParseError) pure (runStmtsParser src txt)
traverse (eval fr) stmts

execIO :: FileReader -> StdGen -> Knowledge -> FilePath -> Text -> IO (Either Err (Result, Ctx))
execIO fr stdgen knowledge src =
runExceptT . flip runStateT (Ctx knowledge stdgen) . runIO fr src

execsIO :: FileReader -> StdGen -> Knowledge -> FilePath -> Text -> IO (Either Err ([Result], Ctx))
execsIO fr stdgen knowledge src =
runExceptT . flip runStateT (Ctx knowledge stdgen) . runsIO fr src

--

readCsvFiles :: FileReader
readCsvFiles name filepath =
either (error . ppErr) pure . parseCsvFile name =<< readFileText filepath


+ 2
- 2
test/Aggregates.hs View File

@@ -48,13 +48,13 @@ tests = do
( resExpr $ rat_ (1 % 2)
)

it "asize" $ do
it "acount" $ do
shouldBe
( runE'
[ "a(1)."
, "a(2)."
, "a(3)."
, "@asize(!a)"
, "@acount(!a)"
]
)
( resExpr $ int_ 3


+ 30
- 0
test/Csv.hs View File

@@ -0,0 +1,30 @@
module Csv where

import Relude
import Test.Hspec
import qualified Data.Text as T

import Language.Logi

import Utils

tests :: Spec
tests = do
describe "csv" $ do
it "parse and count" $
shouldBe
( runEWith' ["file" .= mycsv]
[ "external file = 'file'."
, "@acount(!file)"
]
)
( resExpr $ int_ 2
)

mycsv :: Text
mycsv =
T.intercalate "\n" $ map (T.intercalate ",")
[ ["a", "b", "c"]
, ["178","hello world", "true"]
, ["178/11","'hello world'", "false"]
]

+ 2
- 2
test/EDSL.hs View File

@@ -23,13 +23,13 @@ tests = do
( resExpr $ int_ 6
)

it "fact and query asize" $ do
it "fact and query acount" $ do
shouldBe
( evalE'
[ fact_ "a" (int_ 1)
, fact_ "a" (int_ 2)
, fact_ "a" (int_ 3)
, expr_ $ asize_ "a"
, expr_ $ acount_ "a"
]
)
( resExpr $ int_ 3


+ 8
- 8
test/Functions.hs View File

@@ -24,19 +24,19 @@ tests = do
it "add and query" $ do
shouldBe
( runE $ do
void $ eval $ fact_ "merry" $ sum_ [int_ 3, int_ 5]
void $ eval $ fact_ "merry" $ sum_ [int_ 3, int_ 6]
eval $ query_ "merry" $ var_ "i"
void $ myeval $ fact_ "merry" $ sum_ [int_ 3, int_ 5]
void $ myeval $ fact_ "merry" $ sum_ [int_ 3, int_ 6]
myeval $ query_ "merry" $ var_ "i"
)
(resE [atom_ "merry" (int_ 9), atom_ "merry" (int_ 8)])

it "sum ref and query" $ do
shouldBe
( runE $ do
void $ eval $ fact_ "merry" $ sum_ [int_ 3, int_ 5]
void $ eval $ rule_ "jerry" (var_ "x")
void $ myeval $ fact_ "merry" $ sum_ [int_ 3, int_ 5]
void $ myeval $ rule_ "jerry" (var_ "x")
[atomR_ "merry" $ var_ "x"]
eval $ query_ "jerry" $ var_ "i"
myeval $ query_ "jerry" $ var_ "i"
)
(resE [atom_ "jerry" (int_ 8)])

@@ -60,9 +60,9 @@ tests = do
(runE' ["@avg(1,2,3,4,5,6)"])
(resExpr (rat_ (7%2)))

it "size 'hello world'" $ do
it "count 'hello world'" $ do
shouldBe
(runE' ["@size('hello world')"])
(runE' ["@count('hello world')"])
(resExpr (int_ 11))

it "sum and query" $ do


+ 2
- 0
test/Test.hs View File

@@ -8,6 +8,7 @@ import qualified Query
import qualified Functions
import qualified Aggregates
import qualified EDSL
import qualified Csv

main :: IO ()
main = do
@@ -21,3 +22,4 @@ tests =
Functions.tests
Aggregates.tests
EDSL.tests
Csv.tests

+ 25
- 6
test/Utils.hs View File

@@ -1,35 +1,54 @@
module Utils where

import Relude
import System.IO.Unsafe
import qualified Relude.Unsafe as U

import Control.Monad.Except
import qualified Data.Set as S
import qualified Data.Map as M
import System.Random

import Language.Logi

evalWith :: [(FilePath, Text)] -> Statement -> Eval Result
evalWith files stmt = eval (myreader $ M.fromList files) stmt

myreader :: Map FilePath Text -> FileReader
myreader files name filepath = do
txt <- maybe (error "File not found.") pure $ M.lookup filepath files
either (error . ppErr) pure $ parseCsvFile name txt

myeval :: Statement -> Eval Result
myeval stmt = eval (const $ pure mempty) stmt

evalK :: Statement -> Either Text (Set Rule)
evalK =
fmap getFacts . runK . eval
fmap getFacts . runK . myeval

eval' :: Statement -> Either Text Result
eval' =
runE . eval
runE . myeval

evalE' :: [Statement] -> Either Text Result
evalE' stmts = runE $ U.last <$> traverse eval stmts
evalE' stmts = runE $ U.last <$> traverse myeval stmts

defaultCtx =
Ctx defaultKnowledge (mkStdGen 7)

runEWith' :: [(FilePath, Text)] -> [Text] -> Either Text Result
runEWith' files txts = runE $ do
U.last <$> traverse (runIO (myreader $ M.fromList files) "test") txts


runE' :: [Text] -> Either Text Result
runE' txts = runE $ do
U.last <$> traverse (run "test") txts

runK = first ppErr . runExcept . flip execStateT defaultCtx
runE = first ppErr . runExcept . flip evalStateT defaultCtx
runK :: Eval a -> Either Text Ctx
runK = first ppErr . unsafePerformIO . runExceptT . flip execStateT defaultCtx

runE :: Eval a -> Either Text a
runE = first ppErr . unsafePerformIO . runExceptT . flip evalStateT defaultCtx

getFacts :: Ctx -> Set Rule
getFacts =


Loading…
Cancel
Save