Skip to content

Commit 7f18ddc

Browse files
herrmannoherrmanno
committed
Add REPLs
- add command 'repl <type>' - supported types: 'sets', 'multisets', 'rels' - add command 'repls' Closes #19
1 parent 67e38e2 commit 7f18ddc

21 files changed

+744
-59
lines changed

‎app/App.hs

+26-12
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
module App ( app, taskHelp, taskTypeDescriptions ) where
1+
module App ( app, repl, taskHelp, taskTypeDescriptions, replDescriptions ) where
22

33
import Task (Task(..), describeTask, shortDescribeTask, TaskInput, TaskResult(..))
44
import qualified Tasks.Sets as Set ( task )
@@ -16,6 +16,11 @@ import qualified Tasks.StatementTransform as StatementTransform ( task )
1616
import qualified Tasks.StatementCNF as StatementCNF ( task )
1717
import qualified Tasks.StatementDNF as StatementDNF ( task )
1818
import qualified Tasks.GraphParam as GraphParam ( task )
19+
import Repl (Repl(..), shortDescribeRepl)
20+
import qualified REPL.Sets as Set ( repl )
21+
import qualified REPL.MultiSets as MultiSet ( repl )
22+
import qualified REPL.Relations as Relation ( repl )
23+
1924
import Data.Foldable (find)
2025
import Data.Char (toLower)
2126
import Data.Function (on)
@@ -40,31 +45,40 @@ tasks =
4045
, Structures.task
4146
]
4247

48+
repls :: [Repl]
49+
repls =
50+
[ Set.repl
51+
, MultiSet.repl
52+
, Relation.repl
53+
]
54+
4355
app :: String -- ^ task type
4456
-> TaskInput -- ^ task description
4557
-> TaskResult String -- ^ output
4658
app t d = case findTask t of
4759
(Just t) -> runTask t d
4860
_ -> Error $ "Task '" ++ t ++ "' not found."
4961

62+
repl :: String -> IO String
63+
repl t = case findRepl t of
64+
Just r -> loop r >> return ""
65+
_ -> return $ "Repl '" ++ t ++ "' not found."
66+
5067
taskHelp t = case findTask t of
5168
(Just t) -> describeTask t
5269
_ -> unknownTasktype t
5370

5471
taskTypeDescriptions :: [String]
5572
taskTypeDescriptions = map shortDescribeTask tasks
5673

57-
-- help :: String
58-
-- help = unlines $
59-
-- [ "USAGE"
60-
-- , " <task> <task description file>"
61-
-- , " help <task>"
62-
-- , " help"
63-
-- , ""
64-
-- , "TASK TYPES"
65-
-- ] ++ map ((" "++) . shortDescribeTask) tasks
66-
findTask t = find (compare t . name) tasks
74+
replDescriptions :: [String]
75+
replDescriptions = map shortDescribeRepl repls
76+
77+
findTask t = find (compare t . Task.name) tasks
78+
where compare = (==) `on` map toLower
79+
80+
findRepl t = find (compare t . Repl.name) repls
6781
where compare = (==) `on` map toLower
6882

6983
unknownTasktype t = "Unknown task type '" ++ t ++ "'. Available tasks are:\n" ++ taskTypes
70-
where taskTypes = unlines $ map (\t -> " - " ++ name t) tasks
84+
where taskTypes = unlines $ map (\t -> " - " ++ Task.name t) tasks

‎app/Main.hs

+6-2
Original file line numberDiff line numberDiff line change
@@ -6,17 +6,19 @@ import Paths_autotool_solver as Mod ( version )
66
import Data.Version (showVersion)
77
import Data.FileEmbed (embedStringFile)
88
import Task (TaskInput(input), defaultTaskInput, TaskResult(..))
9-
import App (app, taskHelp, taskTypeDescriptions)
9+
import App (app, repl, taskHelp, taskTypeDescriptions, replDescriptions)
1010

1111
main = do
1212
args <- getArgs
1313
out <- catch (go args) onError
1414
putStrLn out
1515
where
16-
go ["license"] = return $ $(embedStringFile "LICENSE")
16+
go ["license"] = return $(embedStringFile "LICENSE")
1717
go ["version"] = return $ showVersion Mod.version
1818
go ["tasks"] = return $ unlines taskTypeDescriptions
19+
go ["repls"] = return $ unlines replDescriptions
1920
go ["help", taskname] = return $ taskHelp taskname
21+
go ["repl", command] = repl command
2022
go [command,filename] = do
2123
input <- readFile filename
2224
let taskInput = defaultTaskInput { Task.input = input }
@@ -30,6 +32,8 @@ usage = unlines
3032
, " run task: <task> <task description file>"
3133
, " show task types: tasks"
3234
, " show task description: help <task>"
35+
, " repl repl: repl <type>"
36+
, " show repl types: repls"
3337
, " show usage: help"
3438
, " show version: version"
3539
, " show license: license"

‎app/REPL/MultiSets.hs

+99
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,99 @@
1+
{-# LANGUAGE LambdaCase #-}
2+
{-# LANGUAGE ScopedTypeVariables #-}
3+
4+
module REPL.MultiSets where
5+
6+
import Prelude hiding ((+), (-))
7+
import Data.Functor (($>))
8+
import Control.Applicative ((<|>))
9+
import Text.Read (readMaybe)
10+
import Control.Monad (join)
11+
import Data.Tree (Tree(Node))
12+
import qualified Data.Map as M
13+
import qualified Text.ParserCombinators.ReadP as P
14+
import Text.ParserCombinators.ReadP (ReadP)
15+
import System.Console.Haskeline (runInputT, defaultSettings, InputT, getInputLine, outputStrLn)
16+
import Control.Monad.IO.Class (liftIO)
17+
import Control.Exception.Base (Exception, catch, evaluate, throw)
18+
import Repl (Repl(..))
19+
import Autotool.Readable (Readable(..), spacedString, spaced, openPar, closePar)
20+
import Autotool.DAO (toValue)
21+
import qualified Autotool.DAO.Identifier as DAO
22+
import qualified Autotool.DAO.MultiSet as DAO
23+
import qualified Autotool.DAO.Binding as DAO
24+
import Autotool.Data.MultiSetOp ((+), (-), (&))
25+
import Autotool.Data.LazyTree (mkOp0C, Op, showTree, evalTree')
26+
27+
repl :: Repl
28+
repl = Repl
29+
{ name = "multisets"
30+
, description = "Evaluate expressions on multi sets"
31+
, loop = replFn
32+
}
33+
34+
type MM a = M.Map a Int
35+
36+
newtype Context a = Context (M.Map Char (MM a)) deriving (Show)
37+
38+
newtype ReplException = UndefinedVar Char deriving (Show)
39+
40+
instance Exception ReplException
41+
42+
addVar :: Char -> MM a -> Context a -> Context a
43+
addVar k v (Context m) = Context $ M.insert k v m
44+
45+
getVar :: Char -> Context a -> MM a
46+
getVar k (Context m) = case M.lookup k m of
47+
Just v -> v
48+
Nothing -> throw $ UndefinedVar k
49+
50+
data Term a = B (DAO.Binding (MM a)) | T (Tree (Op (Context a) (MM a)))
51+
52+
instance (Show a) => Show (Term a) where
53+
show (B b) = show b
54+
show (T t) = showTree t
55+
56+
instance {-# OVERLAPS #-} (Ord a, Readable a) => Read (Term a) where
57+
readsPrec _ = P.readP_to_S readP
58+
59+
instance (Ord a, Readable a) => Readable (Term a) where
60+
readP = T <$> expr0 <|> B . fmap toValue <$> (readP :: ReadP (DAO.Binding (DAO.MultiSet a)))
61+
where
62+
expr0 = P.chainl1 expr1 (spacedString "&" $> node2 (&))
63+
expr1 = P.chainl1 expr2 (spacedString "+" $> node2 (+))
64+
expr2 = P.chainl1 term (spacedString "-" $> node2 (-))
65+
term = variable <|> spaced (openPar *> expr0 <* closePar)
66+
variable = node0 . var <$> spaced (P.satisfy (`elem` ['A'..'Z']))
67+
var name = mkOp0C [name] (getVar name)
68+
node0 op = Node op []
69+
node1 op a = Node op [a]
70+
node2 op a b = Node op [a,b]
71+
72+
replFn :: IO ()
73+
replFn = runInputT defaultSettings (help >> loop (Context M.empty))
74+
where
75+
help = outputStrLn $ unlines
76+
[ "HELP"
77+
, " Define new multi sets like: S = {q: 1, r: 2}"
78+
, " Evaluate Expressions like: (S + R) & (S - R)"
79+
, ""
80+
, " Available operators (by ascending precedence):"
81+
, " - &"
82+
, " - +"
83+
, " - -"
84+
]
85+
loop :: Context DAO.Identifier -> InputT IO ()
86+
loop c = do
87+
line <- getInputLine "multisets > "
88+
let term = readMaybe <$> line
89+
case join term of
90+
Nothing -> loop c
91+
(Just (B b)) -> let (k,v) = DAO.toPair b in loop (addVar (DAO.fromId k) v c)
92+
(Just (T t)) -> liftIO (eval c t)
93+
>>= \case
94+
(Right val) -> return $ show (toValue val :: DAO.MultiSet DAO.Identifier)
95+
(Left err) -> return err
96+
>>= outputStrLn
97+
>> loop c
98+
eval c t = catch (Right <$> evaluate (evalTree' c t)) onError
99+
onError (UndefinedVar k) = return $ Left $ "Error: Undefined variable " ++ show k

‎app/REPL/Relations.hs

+121
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,121 @@
1+
{-# LANGUAGE LambdaCase #-}
2+
{-# LANGUAGE MultiParamTypeClasses #-}
3+
{-# LANGUAGE FlexibleInstances #-}
4+
{-# LANGUAGE ScopedTypeVariables #-}
5+
6+
module REPL.Relations where
7+
8+
import Prelude hiding ((+), (-), (*))
9+
import Data.Functor (($>))
10+
import Control.Applicative ((<|>))
11+
import Text.Read (readMaybe)
12+
import Control.Monad (join)
13+
import Data.Tree (Tree(Node))
14+
import qualified Data.Set as S
15+
import qualified Data.Map as M
16+
import qualified Text.ParserCombinators.ReadP as P
17+
import Text.ParserCombinators.ReadP (ReadP)
18+
import System.Console.Haskeline (runInputT, defaultSettings, InputT, getInputLine, outputStrLn)
19+
import Control.Exception.Base (Exception, catch, evaluate, throw)
20+
import Control.Monad.IO.Class (liftIO)
21+
import Autotool.Readable (Readable(..), spacedString, spaced, openPar, closePar)
22+
import Autotool.DAO (toValue)
23+
import qualified Autotool.DAO.Set as DAO
24+
import qualified Autotool.DAO.Identifier as DAO
25+
import qualified Autotool.DAO.Binding as DAO
26+
import Autotool.Data.RelOp ((+), (-), (&), (*), inverse, transitiveClosure, reflexiveClosure, RelOpContext(..))
27+
import Autotool.Data.LazyTree (mkOp0C, Op, showTree, evalTree')
28+
import Repl (Repl(..))
29+
30+
repl :: Repl
31+
repl = Repl
32+
{ name = "rels"
33+
, description = "Evaluate expressions on relations"
34+
, loop = replFn
35+
}
36+
37+
type Relation a = S.Set (a,a)
38+
39+
data Context a = Context { _universe :: [a], variables :: M.Map Char (Relation a) }
40+
41+
newtype ReplException = UndefinedVar Char deriving (Show)
42+
43+
instance Exception ReplException
44+
45+
getVariable c k = case M.lookup k (variables c) of
46+
Just v -> v
47+
Nothing -> throw $ UndefinedVar k
48+
49+
addVariable :: Char -> Relation a -> Context a -> Context a
50+
addVariable k v (Context uni vars) = Context uni (M.insert k v vars)
51+
52+
setUniverse :: [a] -> Context a -> Context a
53+
setUniverse u (Context _ vars) = Context u vars
54+
55+
instance (RelOpContext a) (Context a) where
56+
universe (Context u _) = u
57+
58+
data Term a = B (DAO.Binding (Relation a)) | U [a] | T (Tree (Op (Context a) (Relation a)))
59+
60+
instance (Show a) => Show (Term a) where
61+
show (B b) = show b
62+
show (T t) = showTree t
63+
64+
instance {-# OVERLAPS #-} (Ord a, Readable a) => Read (Term a) where
65+
readsPrec _ = P.readP_to_S readP
66+
67+
instance (Ord a, Readable a) => Readable (Term a) where
68+
readP =
69+
T <$> expr0
70+
<|> B . fmap toValue <$> (readP :: ReadP (DAO.Binding (DAO.Set (a,a))))
71+
<|> U <$> (spacedString "universe" *> readP)
72+
where
73+
expr0 = P.chainl1 expr1 (spacedString "&" $> node2 (&))
74+
expr1 = P.chainl1 expr2 (spacedString "+" $> node2 (+))
75+
expr2 = P.chainl1 expr3 (spacedString "-" $> node2 (-))
76+
expr3 = P.chainl1 term (spacedString "." $> node2 (*))
77+
term =
78+
variable
79+
<|> node1 inverse <$> (spacedString "inverse" *> (variable <|> (openPar *> expr0 <* closePar)))
80+
<|> node1 transitiveClosure <$> (spacedString "transitive_cl" *> (variable <|> (openPar *> expr0 <* closePar)))
81+
<|> node1 reflexiveClosure <$> (spacedString "reflexive_cl" *> (variable <|> (openPar *> expr0 <* closePar)))
82+
variable = node0 . var <$> spaced (P.satisfy (`elem` ['A'..'Z']))
83+
var name = mkOp0C [name] (`getVariable` name)
84+
node0 op = Node op []
85+
node1 op a = Node op [a]
86+
node2 op a b = Node op [a,b]
87+
88+
replFn :: IO ()
89+
replFn = runInputT defaultSettings (help >> loop (Context [] M.empty))
90+
where
91+
help = outputStrLn $ unlines
92+
[ "HELP"
93+
, " Define new sets relations: S = {(1,2), (3,4)}"
94+
, " Define universe: universe [1,2,3,4]"
95+
, " Evaluate Expressions like: (S + R) . (S - R)"
96+
, ""
97+
, " Available operators:"
98+
, " - &"
99+
, " - +"
100+
, " - -"
101+
, " - ."
102+
, " - inverse (needs defined universe)"
103+
, " - transitive_cl"
104+
, " - reflexive_cl"
105+
]
106+
loop :: Context Int -> InputT IO ()
107+
loop c = do
108+
line <- getInputLine "relations > "
109+
let term = readMaybe <$> line
110+
case join term of
111+
Nothing -> loop c
112+
(Just (B b)) -> let (k,v) = DAO.toPair b in loop (addVariable (DAO.fromId k) v c)
113+
(Just (U u)) -> loop (setUniverse u c)
114+
(Just (T t)) -> liftIO (eval c t)
115+
>>= \case
116+
(Right val) -> return $ show (toValue val :: DAO.Set (Int,Int))
117+
(Left err) -> return err
118+
>>= outputStrLn
119+
>> loop c
120+
eval c t = catch (Right <$> evaluate (evalTree' c t)) onError
121+
onError (UndefinedVar k) = return $ Left $ "Error: Undefined variable " ++ show k

0 commit comments

Comments
 (0)