exploring-interpreters 1.5.0.1 → 1.6.0.0

raw patch · 10 files changed

+1360/−1351 lines, 10 filesdep ~aesondep ~attoparsecdep ~bytestringsetup-changed

Dependency ranges changed: aeson, attoparsec, bytestring, containers, exceptions, fgl, haskeline, http-types, mtl, network, scientific, text, transformers

Files

• CHANGELOG.md +40/−40
• LICENSE +30/−30
• Language/Explorer/Basic.hs +107/−102
• Language/Explorer/Monadic.hs +268/−268
• Language/Explorer/Pure.hs +94/−90
• Language/Explorer/Tools/Protocol.hs +450/−450
• Language/Explorer/Tools/REPL.hs +73/−73
• Setup.hs +2/−2
• examples/Whilelang.hs +248/−248
• exploring-interpreters.cabal +48/−48

@@ -1,41 +1,41 @@-# Revision history for exploring-interpreters--## 0.2.0.0 -- 2021-03-15-* First official version.--## 0.3.0.0 -- 2021-03-16-* Require that definitional interpreters return configurations in the Maybe monad.-  This adds support for run-time errors by returning Nothing when an errors occurs.--## 0.3.1.0 -- 2021-04-18-* This version adds the 'leaves' function to the exploring interpreter.--## 0.3.2.0 -- 2021-06-29-* This version adds functionality to support exporting and importing of execution environments.-This functionality is provided via the 'toExport' and 'fromExport' functions.-* Furthermore, this version also exports the initial reference.--## 0.3.2.1 -- 2021-10-01-* Add the toExport and fromExport functions to the exported functions in the pure module.--## 0.4.0.0 -- 2021-10-01-* fromExport function now correctly determines the referece to use for generation of new nodes.--## 1.0.0.0 -- 2021-10-06-* Change explorer model to the new model where the exploration is always reported-by a tree and sharing is possible via the optional shadow graph.-Furthermore, the *jump* action is introduced to allow jumping to any node in the tree without the -destructive property. In addition, the *revert* action is now always destructive and can only operate -on the current trace.-* Add the Tools module.-This module includes an implementation of the exploring interpreter protocol and an implementation-of an language parametric REPL.--## 1.2.0.0 -- 2022-01-13-* Change the readline dependency to haskeline.--## 1.3.0.0 -- 2022-01-13-* Bump and freeze haskeline dependency.--## 1.5.0.0 -- 2024-01-19+# Revision history for exploring-interpreters
+
+## 0.2.0.0 -- 2021-03-15
+* First official version.
+
+## 0.3.0.0 -- 2021-03-16
+* Require that definitional interpreters return configurations in the Maybe monad.
+  This adds support for run-time errors by returning Nothing when an errors occurs.
+
+## 0.3.1.0 -- 2021-04-18
+* This version adds the 'leaves' function to the exploring interpreter.
+
+## 0.3.2.0 -- 2021-06-29
+* This version adds functionality to support exporting and importing of execution environments.
+This functionality is provided via the 'toExport' and 'fromExport' functions.
+* Furthermore, this version also exports the initial reference.
+
+## 0.3.2.1 -- 2021-10-01
+* Add the toExport and fromExport functions to the exported functions in the pure module.
+
+## 0.4.0.0 -- 2021-10-01
+* fromExport function now correctly determines the referece to use for generation of new nodes.
+
+## 1.0.0.0 -- 2021-10-06
+* Change explorer model to the new model where the exploration is always reported
+by a tree and sharing is possible via the optional shadow graph.
+Furthermore, the *jump* action is introduced to allow jumping to any node in the tree without the 
+destructive property. In addition, the *revert* action is now always destructive and can only operate 
+on the current trace.
+* Add the Tools module.
+This module includes an implementation of the exploring interpreter protocol and an implementation
+of an language parametric REPL.
+
+## 1.2.0.0 -- 2022-01-13
+* Change the readline dependency to haskeline.
+
+## 1.3.0.0 -- 2022-01-13
+* Bump and freeze haskeline dependency.
+
+## 1.5.0.0 -- 2024-01-19
 * Bump the text dependency, and bump + bound the aeson dependency.

@@ -1,30 +1,30 @@-Copyright (c) 2021, Damian Frolich--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Damian Frolich nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+Copyright (c) 2021, Damian Frolich
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Damian Frolich nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -1,103 +1,108 @@-{-# LANGUAGE ConstraintKinds #-}--module Language.Explorer.Basic-    ( Explorer-    , mkExplorer-    , mkExplorerNoSharing-    , execute-    , executeAll-    , revert-    , ExplorerM.toTree-    , config-    , currRef-    , Ref-    , deref-    , leaves-    , getTrace-    , getTraces-    , getPathsFromTo-    , getPathFromTo-    , executionGraph-    , fromExport-    , toExport-    ) where--import qualified Language.Explorer.Monadic as ExplorerM-import Control.Monad.Identity--import qualified Data.IntMap as IntMap-import Data.List-import Data.Functor-import Data.Foldable-import Data.Monoid ()-import Data.Graph.Inductive.Graph (emap)---- We shadow instead of exporting directly to make the user interaction--- the same.-type Ref = ExplorerM.Ref-type Explorer a b = ExplorerM.Explorer a Identity b ()-type BasicLanguage p c = Eq p--mkExplorer :: BasicLanguage p c => Bool -> (c -> c -> Bool) -> (p -> c -> Maybe c) -> c -> Explorer p c-mkExplorer shadow eqfunc definterp initialConf = ExplorerM.mkExplorer shadow eqfunc (wrap definterp) initialConf--mkExplorerNoSharing :: BasicLanguage p c => (p -> c -> Maybe c) -> c -> Explorer p c-mkExplorerNoSharing = mkExplorer False (const . const $ False)--currRef :: Explorer a b -> Ref-currRef = ExplorerM.currRef--config :: Explorer a b -> b-config = ExplorerM.config--deref :: Explorer p c -> Ref -> Maybe c-deref = ExplorerM.deref---- This should be able with func composition.-wrap :: Monad m => (a -> b -> Maybe b) -> a -> b -> m (Maybe b, ())-wrap def p e = return $ (def p e, ())--execute :: BasicLanguage p c => p -> Explorer p c -> Explorer p c-execute p e = fst $ runIdentity $ ExplorerM.execute p e--executeAll :: BasicLanguage p c => [p] -> Explorer p c -> Explorer p c-executeAll p e = fst $ runIdentity $ ExplorerM.executeAll p e--revert :: ExplorerM.Ref -> Explorer p c -> Maybe (Explorer p c)-revert = ExplorerM.revert--removeOutput :: ((Ref, c), (p, o), (Ref, c)) -> ((Ref, c), p, (Ref, c))-removeOutput (s, (p, _), t) = (s, p, t)--incomingEdges :: Ref -> Explorer p c -> [((Ref, c), p, (Ref, c))]-incomingEdges r e = map removeOutput $ ExplorerM.incomingEdges r e--getTrace :: Explorer p c -> [((Ref, c), p, (Ref, c))]-getTrace e = map removeOutput $ ExplorerM.getTrace e--getTraces :: Explorer p c -> [[((Ref, c), p, (Ref, c))]]-getTraces e = map (map removeOutput) $ ExplorerM.getTraces e--getPathsFromTo :: Explorer p c -> Ref -> Ref -> [[((Ref, c), p, (Ref, c))]]-getPathsFromTo e s t = map (map removeOutput) $ ExplorerM.getPathsFromTo e s t--getPathFromTo :: Explorer p c -> Ref -> Ref -> [((Ref, c), p, (Ref, c))]-getPathFromTo e s t = map removeOutput $ ExplorerM.getPathFromTo e s t--executionGraph :: Explorer p c -> ((Ref, c), [(Ref, c)], [((Ref, c), p, (Ref, c))])-executionGraph e = (curr, nodes, map removeOutput graph)-  where-    (curr, nodes, graph) = ExplorerM.executionGraph e--leaves :: Explorer p c -> [(Ref, c)]-leaves = ExplorerM.leaves--toExport :: Explorer p c -> (Ref, [(Ref, c)], [(Ref, Ref, p)])-toExport = removeOut . ExplorerM.toExport-  where-    removeOut (c, nodes, edges) = (c, nodes, map (\(s, t, (p, _)) -> (s, t, p)) edges)--fromExport :: Explorer p c -> (Ref, [(Ref, c)], [(Ref, Ref, p)]) -> Explorer p c-fromExport e exported = ExplorerM.fromExport e (addOut exported)-  where+{-# LANGUAGE ConstraintKinds #-}
+
+module Language.Explorer.Basic
+    ( Explorer
+    , mkExplorer
+    , mkExplorerNoSharing
+    , execute
+    , executeAll
+    , revert
+    , jump
+    , ExplorerM.toTree
+    , incomingEdges
+    , config
+    , currRef
+    , Ref
+    , deref
+    , leaves
+    , getTrace
+    , getTraces
+    , getPathsFromTo
+    , getPathFromTo
+    , executionGraph
+    , fromExport
+    , toExport
+    ) where
+
+import qualified Language.Explorer.Monadic as ExplorerM
+import Control.Monad.Identity
+
+import qualified Data.IntMap as IntMap
+import Data.List
+import Data.Functor
+import Data.Foldable
+import Data.Monoid ()
+import Data.Graph.Inductive.Graph (emap)
+
+-- We shadow instead of exporting directly to make the user interaction
+-- the same.
+type Ref = ExplorerM.Ref
+type Explorer a b = ExplorerM.Explorer a Identity b ()
+type BasicLanguage p c = Eq p
+
+mkExplorer :: BasicLanguage p c => Bool -> (c -> c -> Bool) -> (p -> c -> Maybe c) -> c -> Explorer p c
+mkExplorer shadow eqfunc definterp initialConf = ExplorerM.mkExplorer shadow eqfunc (wrap definterp) initialConf
+
+mkExplorerNoSharing :: BasicLanguage p c => (p -> c -> Maybe c) -> c -> Explorer p c
+mkExplorerNoSharing = mkExplorer False (const . const $ False)
+
+currRef :: Explorer a b -> Ref
+currRef = ExplorerM.currRef
+
+config :: Explorer a b -> b
+config = ExplorerM.config
+
+deref :: Explorer p c -> Ref -> Maybe c
+deref = ExplorerM.deref
+
+-- This should be able with func composition.
+wrap :: Monad m => (a -> b -> Maybe b) -> a -> b -> m (Maybe b, ())
+wrap def p e = return $ (def p e, ())
+
+execute :: BasicLanguage p c => p -> Explorer p c -> Explorer p c
+execute p e = fst $ runIdentity $ ExplorerM.execute p e
+
+executeAll :: BasicLanguage p c => [p] -> Explorer p c -> Explorer p c
+executeAll p e = fst $ runIdentity $ ExplorerM.executeAll p e
+
+revert :: ExplorerM.Ref -> Explorer p c -> Maybe (Explorer p c)
+revert = ExplorerM.revert
+
+jump :: ExplorerM.Ref -> Explorer p c -> Maybe (Explorer p c)
+jump = ExplorerM.jump
+
+removeOutput :: ((Ref, c), (p, o), (Ref, c)) -> ((Ref, c), p, (Ref, c))
+removeOutput (s, (p, _), t) = (s, p, t)
+
+incomingEdges :: Ref -> Explorer p c -> [((Ref, c), p, (Ref, c))]
+incomingEdges r e = map removeOutput $ ExplorerM.incomingEdges r e
+
+getTrace :: Explorer p c -> [((Ref, c), p, (Ref, c))]
+getTrace e = map removeOutput $ ExplorerM.getTrace e
+
+getTraces :: Explorer p c -> [[((Ref, c), p, (Ref, c))]]
+getTraces e = map (map removeOutput) $ ExplorerM.getTraces e
+
+getPathsFromTo :: Explorer p c -> Ref -> Ref -> [[((Ref, c), p, (Ref, c))]]
+getPathsFromTo e s t = map (map removeOutput) $ ExplorerM.getPathsFromTo e s t
+
+getPathFromTo :: Explorer p c -> Ref -> Ref -> [((Ref, c), p, (Ref, c))]
+getPathFromTo e s t = map removeOutput $ ExplorerM.getPathFromTo e s t
+
+executionGraph :: Explorer p c -> ((Ref, c), [(Ref, c)], [((Ref, c), p, (Ref, c))])
+executionGraph e = (curr, nodes, map removeOutput graph)
+  where
+    (curr, nodes, graph) = ExplorerM.executionGraph e
+
+leaves :: Explorer p c -> [(Ref, c)]
+leaves = ExplorerM.leaves
+
+toExport :: Explorer p c -> (Ref, [(Ref, c)], [(Ref, Ref, p)])
+toExport = removeOut . ExplorerM.toExport
+  where
+    removeOut (c, nodes, edges) = (c, nodes, map (\(s, t, (p, _)) -> (s, t, p)) edges)
+
+fromExport :: Explorer p c -> (Ref, [(Ref, c)], [(Ref, Ref, p)]) -> Explorer p c
+fromExport e exported = ExplorerM.fromExport e (addOut exported)
+  where
     addOut (c, nodes, edges) = (c, nodes, map (\(s, t, p) -> (s, t, (p, ()))) edges)

@@ -1,268 +1,268 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ConstraintKinds #-}---module Language.Explorer.Monadic-    ( Explorer-    , mkExplorer-    , mkExplorerNoSharing-    , execute-    , executeAll-    , revert-    , jump-    , toTree-    , incomingEdges-    , config-    , execEnv-    , currRef-    , leaves-    , Ref-    , Language-    , deref-    , getTrace-    , getTraces-    , getPathsFromTo-    , getPathFromTo-    , executionGraph-    , shadowExecEnv-    , eqClasses-    , initialRef-    , fromExport-    , toExport-    ) where--import Data.Graph.Inductive.Graph-import Data.Graph.Inductive.PatriciaTree-import Data.Graph.Inductive.Query-import Data.Graph.Inductive.Query.SP-import Data.Tree (Tree(..))--import qualified Data.IntMap as IntMap-import Data.List-import Data.Foldable-import Data.Maybe--type Ref = Int-type Language p m c o = (Eq p, Eq o, Monad m, Monoid o)--data Explorer programs m configs output where-    Explorer :: Language programs m configs output =>-        { shadowing :: Bool -- Shadow the exploration tree in a shadow graph.-        , defInterp :: programs -> configs -> m (Maybe configs, output)-        , config :: configs -- Cache the config-        , currRef :: Ref-        , genRef :: Ref-        , cmap :: IntMap.IntMap configs-        , execEnv :: Gr Ref (programs, output)-        , shadowExecEnv :: Gr [Ref] (programs, output)-        , configEq :: configs -> configs -> Bool-        } -> Explorer programs m configs output---mkExplorer :: Language p m c o => Bool -> (c -> c -> Bool) -> (p -> c -> m (Maybe c, o)) -> c -> Explorer p m c o-mkExplorer shadow shadowEq definterp conf = Explorer-    { defInterp = definterp-    , config = conf-    , genRef = 1 -- Currently generate references by increasing a counter.-    , currRef = initialRef-    , cmap = IntMap.fromList [(initialRef, conf)]-    , execEnv = mkGraph [(initialRef, initialRef)] []-    , shadowExecEnv = mkGraph [(initialRef, [initialRef])] []-    , shadowing = shadow-    , configEq = shadowEq-}--initialRef :: Int-initialRef = 1--mkExplorerNoSharing :: Language p m c o  => (p -> c -> m (Maybe c, o)) -> c -> Explorer p m c o-mkExplorerNoSharing = mkExplorer False (\_ -> \_ -> False)--deref :: Explorer p m c o -> Ref -> Maybe c-deref e r = IntMap.lookup r (cmap e)--findRef :: Explorer p m c o -> c -> (c -> Bool) -> Maybe (Ref, c)-findRef e c eq = find (\(r, c') -> eq c') (IntMap.toList (cmap e))--addNewPath :: Explorer p m c o -> p -> o -> c -> Explorer p m c o-addNewPath e p o c = e { config = c, currRef = newref, genRef = newref, cmap = IntMap.insert newref c (cmap e),-     execEnv = insNode (newref, newref) $ insEdge (currRef e, newref, (p,o)) (execEnv e)}-     where newref = genRef e + 1---findNodeRef :: Gr [Ref] (p, o) -> Ref -> Ref-findNodeRef g r = fst $ fromJust $ find (\(_, rs) -> r `elem` rs) $ labNodes g---updateShadowEnv :: Language p m c o => Explorer p m c o -> (p, c, o, Ref, Ref) -> Explorer p m c o-updateShadowEnv e (p, newconf, output, newref, oldref) =-  case findRef e newconf (configEq e newconf) of-    Just (r', _) ->-      if hasLEdge shadowEnv (nref, findNodeRef shadowEnv r', (p, output))-        then e-        else e {-          shadowExecEnv = updateLabel (findNodeRef shadowEnv r', newref, p, output) $ insEdge (nref, findNodeRef shadowEnv r', (p, output)) shadowEnv-        }-    Nothing -> e {-      shadowExecEnv = insNode (newref, [newref]) $ insEdge (nref, newref, (p, output)) $ shadowExecEnv e-    }-    where-      shadowEnv = shadowExecEnv e-      nref = findNodeRef shadowEnv oldref-      updateLabel (target, add_to_label, p, output) gr =-        case match target gr of-          (Just (toadj, node, label, fromadj), decomgr) -> (toadj, node, add_to_label : label, fromadj) & decomgr-          _ -> error "Shadow execution environment is inconsistent."---updateExecEnvs :: Language p m c o => Explorer p m c o -> (p, c, o) -> Explorer p m c o-updateExecEnvs e (p, newconf, output)-  | shadowing e = addNewPath (updateShadowEnv e (p, newconf, output, (currRef newexplorer), (currRef e))) p output newconf-  | otherwise = newexplorer-  where-    newexplorer = addNewPath e p output newconf--execute :: Language p m c o =>  p -> Explorer p m c o -> m (Explorer p m c o, o)-execute p e =-  do (mcfg, o) <- defInterp e p (config e)-     case mcfg of-       Just cfg -> return (updateExecEnvs e (p, cfg, o), o)-       Nothing  -> return (e, o)--executeAll :: Language p m c o => [p] -> Explorer p m c o -> m (Explorer p m c o, o)-executeAll ps exp = foldlM executeCollect (exp, mempty) ps-  where executeCollect (exp, out) p = do (res, out') <- execute p exp-                                         return (res, out `mappend` out')--deleteMap :: [Ref] -> IntMap.IntMap a -> IntMap.IntMap a-deleteMap xs m = foldl (flip IntMap.delete) m xs---deleteFromShadowEnv :: [(Ref, Ref)] -> Gr [Ref] po -> Gr [Ref] po-deleteFromShadowEnv [(l, r)] gr = case match r gr of-  (Just (toadj, node, label, fromadj), decomgr) -> (toadj, node, label \\ [l], fromadj) & decomgr-  _ -> error "Inconsistent shadow env."-deleteFromShadowEnv (x:xs) gr = deleteFromShadowEnv xs (deleteFromShadowEnv [x] gr)--cleanEdges :: [Ref] -> [(Ref, Ref, (p, o))] -> [(Ref, Ref, (p, o))]-cleanEdges ref edg = filter (\(s, t, l) -> not $ t `elem` ref) edg--cleanShadowEnv :: Bool -> [Ref] -> Gr [Ref] (p, o) -> Gr [Ref] (p, o)-cleanShadowEnv False _ g = g-cleanShadowEnv True nds g = shadowEnv''-  where-    shadowEnv' = deleteFromShadowEnv (map (\r -> (r, findNodeRef g r)) nds) g-    nodesToDel' = map fst (filter (\(r, labels) -> labels == []) $ labNodes (shadowEnv'))-    edgesToDel' = filter (\(s, t) -> s `elem` nodesToDel' || t `elem` nodesToDel') (edges shadowEnv')-    shadowEnv'' = (delEdges edgesToDel' . delNodes nodesToDel') shadowEnv'--data RevertableStatus = ContinueRevert | StopRevert deriving Show--findRevertableNodes gr source target =-  case findNextNodeInPath gr source target of-    (Just node) -> fst $ findRevertableNodes' gr node target-    Nothing     -> []-  where-    findNextNodeInPath gr source target = find (\n -> target `elem` (reachable n gr)) (suc gr source)-    findRevertableNodes' gr source target-      | source == target = if outdeg gr source > 1 then ([], StopRevert) else ([source], ContinueRevert)-      | otherwise = case findNextNodeInPath gr source target of-        (Just node) -> case findRevertableNodes' gr node target of-          (res, StopRevert) -> (res, StopRevert)-          (res, ContinueRevert) -> if outdeg gr source > 1 then (res, StopRevert) else (source : res, ContinueRevert)-        Nothing -> ([], ContinueRevert)--revert :: Ref -> Explorer p m c o -> Maybe (Explorer p m c o)-revert r e-  | currRef e `elem` reachNodes =-      jump r e >>= \e' -> return $ e' { execEnv = mkGraph (zip remainNodes remainNodes) $ cleanEdges reachNodes (labEdges $ execEnv e')-                                      ,  cmap = deleteMap reachNodes (cmap e')-                                      , shadowExecEnv = cleanShadowEnv (shadowing e') reachNodes (shadowExecEnv e')}-  | otherwise = Nothing-  where-    reachNodes = findRevertableNodes gr r (currRef e)-    remainNodes = nodes gr \\ reachNodes-    gr = execEnv e--jump :: Ref -> Explorer p m c o -> Maybe (Explorer p m c o)-jump r e = case deref e r of-             (Just c) -> return $ e { config = c, currRef = r }-             Nothing -> Nothing--toTree :: Explorer p m c o -> Tree (Ref, c)-toTree exp = mkTree initialRef-  where graph = execEnv exp-        target (_, r, _) = r-        mkTree r = Node (r, cmap exp IntMap.! r) (map (mkTree . target) (out graph r))---incomingEdges :: Ref -> Explorer p m c o -> [((Ref, c), (p, o), (Ref, c))]-incomingEdges ref e = foldr (\(s, t, l) acc ->  [((s, unpack s), l, (t, unpack t))] ++ acc) [] (filter (\(_, t, _) -> t == ref) (labEdges (execEnv e)))-  where-    unpack ref = fromJust $ deref e ref--getTrace :: Explorer p m c o -> [((Ref, c), (p, o), (Ref, c))]-getTrace e = getPathFromTo e initialRef (currRef e)--getTraces :: Explorer p m c o -> [[((Ref, c), (p, o), (Ref, c))]]-getTraces e = getPathsFromTo e initialRef (currRef e)---mapOut :: Explorer p m c o -> Gr Ref (p, o) -> [Ref] -> Ref -> (Ref, Ref, (p,o)) -> Maybe [[((Ref, c), (p, o), (Ref, c))]]-mapOut exp gr visited goal (s, t, (l, o))-  | goal == t = Just $ [[((s, unpack s), (l, o), (t, unpack t))]] ++ explore-  | otherwise = case t `elem` visited of-                  True -> Nothing-                  False -> Just explore-  where-    explore = map ((:)((s, unpack s), (l, o), (t, unpack t))) (concat $ catMaybes $ map (mapOut exp gr (t : visited) goal) (out gr t))-    unpack ref = fromJust $ deref exp ref---getPathsFromTo :: Explorer p m c o -> Ref -> Ref -> [[((Ref, c), (p, o), (Ref, c))]]-getPathsFromTo exp from to = concat $ catMaybes $ map (mapOut exp (execEnv exp) [from] to) (out (execEnv exp) from)--getPathFromTo :: Explorer p m c o -> Ref -> Ref -> [((Ref, c), (p, o), (Ref, c))]-getPathFromTo exp from to =-  case getPathsFromTo exp from to of-    [] -> []-    (x:_) -> x----executionGraph :: Explorer p m c o -> ((Ref, c), [(Ref, c)], [((Ref, c), (p, o), (Ref, c))])-executionGraph exp =-  (curr, nodes, edges)-  where-    curr = (currRef exp, config exp)-    nodes = IntMap.toList $ cmap exp-    edges = map (\(s, t, p) -> ((s, fromJust $ deref exp s), p, (t, fromJust $ deref exp t)) ) (labEdges (execEnv exp))--{-|-  Returns all configurations that have not been the source for an execute action.-  This corresponds to leaves in a tree or nodes without an outbound-edge in a graph.--}-leaves :: Explorer p m c o -> [(Ref, c)]-leaves exp = map refToPair leaf_nodes-  where-    env = execEnv exp-    refToPair = \r -> (r, fromJust $ deref exp r)-    leaf_nodes = nodes $ nfilter (\n -> (==0) $ outdeg env n) env---toExport :: Explorer p m c o -> (Ref, [(Ref, c)], [(Ref, Ref, (p, o))])-toExport exp = (currRef exp, IntMap.toList $ cmap exp, labEdges $ execEnv exp)--fromExport :: Explorer p m c o -> (Ref, [(Ref, c)], [(Ref, Ref, (p, o))]) -> Explorer p m c o-fromExport exp (curr, nds, edgs) = exp { genRef = findMax nds,-                                         config = findCurrentConf curr nds,-                                         currRef = curr,-                                         cmap = IntMap.fromList nds,-                                         execEnv = mkGraph (map (\(x, _) -> (x, x)) nds) edgs }-  where findMax l = maximum $ map fst l-        findCurrentConf curr nds = case lookup curr nds of-                                     Just conf -> conf-                                     Nothing   -> error "no config found"--eqClasses :: Explorer p m c o -> [[Ref]]-eqClasses expl = map snd $ labNodes $ shadowExecEnv expl+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ConstraintKinds #-}
+
+
+module Language.Explorer.Monadic
+    ( Explorer
+    , mkExplorer
+    , mkExplorerNoSharing
+    , execute
+    , executeAll
+    , revert
+    , jump
+    , toTree
+    , incomingEdges
+    , config
+    , execEnv
+    , currRef
+    , leaves
+    , Ref
+    , Language
+    , deref
+    , getTrace
+    , getTraces
+    , getPathsFromTo
+    , getPathFromTo
+    , executionGraph
+    , shadowExecEnv
+    , eqClasses
+    , initialRef
+    , fromExport
+    , toExport
+    ) where
+
+import Data.Graph.Inductive.Graph
+import Data.Graph.Inductive.PatriciaTree
+import Data.Graph.Inductive.Query
+import Data.Graph.Inductive.Query.SP
+import Data.Tree (Tree(..))
+
+import qualified Data.IntMap as IntMap
+import Data.List
+import Data.Foldable
+import Data.Maybe
+
+type Ref = Int
+type Language p m c o = (Eq p, Eq o, Monad m, Monoid o)
+
+data Explorer programs m configs output where
+    Explorer :: Language programs m configs output =>
+        { shadowing :: Bool -- Shadow the exploration tree in a shadow graph.
+        , defInterp :: programs -> configs -> m (Maybe configs, output)
+        , config :: configs -- Cache the config
+        , currRef :: Ref
+        , genRef :: Ref
+        , cmap :: IntMap.IntMap configs
+        , execEnv :: Gr Ref (programs, output)
+        , shadowExecEnv :: Gr [Ref] (programs, output)
+        , configEq :: configs -> configs -> Bool
+        } -> Explorer programs m configs output
+
+
+mkExplorer :: Language p m c o => Bool -> (c -> c -> Bool) -> (p -> c -> m (Maybe c, o)) -> c -> Explorer p m c o
+mkExplorer shadow shadowEq definterp conf = Explorer
+    { defInterp = definterp
+    , config = conf
+    , genRef = 1 -- Currently generate references by increasing a counter.
+    , currRef = initialRef
+    , cmap = IntMap.fromList [(initialRef, conf)]
+    , execEnv = mkGraph [(initialRef, initialRef)] []
+    , shadowExecEnv = mkGraph [(initialRef, [initialRef])] []
+    , shadowing = shadow
+    , configEq = shadowEq
+}
+
+initialRef :: Int
+initialRef = 1
+
+mkExplorerNoSharing :: Language p m c o  => (p -> c -> m (Maybe c, o)) -> c -> Explorer p m c o
+mkExplorerNoSharing = mkExplorer False (\_ -> \_ -> False)
+
+deref :: Explorer p m c o -> Ref -> Maybe c
+deref e r = IntMap.lookup r (cmap e)
+
+findRef :: Explorer p m c o -> c -> (c -> Bool) -> Maybe (Ref, c)
+findRef e c eq = find (\(r, c') -> eq c') (IntMap.toList (cmap e))
+
+addNewPath :: Explorer p m c o -> p -> o -> c -> Explorer p m c o
+addNewPath e p o c = e { config = c, currRef = newref, genRef = newref, cmap = IntMap.insert newref c (cmap e),
+     execEnv = insNode (newref, newref) $ insEdge (currRef e, newref, (p,o)) (execEnv e)}
+     where newref = genRef e + 1
+
+
+findNodeRef :: Gr [Ref] (p, o) -> Ref -> Ref
+findNodeRef g r = fst $ fromJust $ find (\(_, rs) -> r `elem` rs) $ labNodes g
+
+
+updateShadowEnv :: Language p m c o => Explorer p m c o -> (p, c, o, Ref, Ref) -> Explorer p m c o
+updateShadowEnv e (p, newconf, output, newref, oldref) =
+  case findRef e newconf (configEq e newconf) of
+    Just (r', _) ->
+      if hasLEdge shadowEnv (nref, findNodeRef shadowEnv r', (p, output))
+        then e
+        else e {
+          shadowExecEnv = updateLabel (findNodeRef shadowEnv r', newref, p, output) $ insEdge (nref, findNodeRef shadowEnv r', (p, output)) shadowEnv
+        }
+    Nothing -> e {
+      shadowExecEnv = insNode (newref, [newref]) $ insEdge (nref, newref, (p, output)) $ shadowExecEnv e
+    }
+    where
+      shadowEnv = shadowExecEnv e
+      nref = findNodeRef shadowEnv oldref
+      updateLabel (target, add_to_label, p, output) gr =
+        case match target gr of
+          (Just (toadj, node, label, fromadj), decomgr) -> (toadj, node, add_to_label : label, fromadj) & decomgr
+          _ -> error "Shadow execution environment is inconsistent."
+
+
+updateExecEnvs :: Language p m c o => Explorer p m c o -> (p, c, o) -> Explorer p m c o
+updateExecEnvs e (p, newconf, output)
+  | shadowing e = addNewPath (updateShadowEnv e (p, newconf, output, (currRef newexplorer), (currRef e))) p output newconf
+  | otherwise = newexplorer
+  where
+    newexplorer = addNewPath e p output newconf
+
+execute :: Language p m c o =>  p -> Explorer p m c o -> m (Explorer p m c o, o)
+execute p e =
+  do (mcfg, o) <- defInterp e p (config e)
+     case mcfg of
+       Just cfg -> return (updateExecEnvs e (p, cfg, o), o)
+       Nothing  -> return (e, o)
+
+executeAll :: Language p m c o => [p] -> Explorer p m c o -> m (Explorer p m c o, o)
+executeAll ps exp = foldlM executeCollect (exp, mempty) ps
+  where executeCollect (exp, out) p = do (res, out') <- execute p exp
+                                         return (res, out `mappend` out')
+
+deleteMap :: [Ref] -> IntMap.IntMap a -> IntMap.IntMap a
+deleteMap xs m = foldl (flip IntMap.delete) m xs
+
+
+deleteFromShadowEnv :: [(Ref, Ref)] -> Gr [Ref] po -> Gr [Ref] po
+deleteFromShadowEnv [(l, r)] gr = case match r gr of
+  (Just (toadj, node, label, fromadj), decomgr) -> (toadj, node, label \\ [l], fromadj) & decomgr
+  _ -> error "Inconsistent shadow env."
+deleteFromShadowEnv (x:xs) gr = deleteFromShadowEnv xs (deleteFromShadowEnv [x] gr)
+
+cleanEdges :: [Ref] -> [(Ref, Ref, (p, o))] -> [(Ref, Ref, (p, o))]
+cleanEdges ref edg = filter (\(s, t, l) -> not $ t `elem` ref) edg
+
+cleanShadowEnv :: Bool -> [Ref] -> Gr [Ref] (p, o) -> Gr [Ref] (p, o)
+cleanShadowEnv False _ g = g
+cleanShadowEnv True nds g = shadowEnv''
+  where
+    shadowEnv' = deleteFromShadowEnv (map (\r -> (r, findNodeRef g r)) nds) g
+    nodesToDel' = map fst (filter (\(r, labels) -> labels == []) $ labNodes (shadowEnv'))
+    edgesToDel' = filter (\(s, t) -> s `elem` nodesToDel' || t `elem` nodesToDel') (edges shadowEnv')
+    shadowEnv'' = (delEdges edgesToDel' . delNodes nodesToDel') shadowEnv'
+
+data RevertableStatus = ContinueRevert | StopRevert deriving Show
+
+findRevertableNodes gr source target =
+  case findNextNodeInPath gr source target of
+    (Just node) -> fst $ findRevertableNodes' gr node target
+    Nothing     -> []
+  where
+    findNextNodeInPath gr source target = find (\n -> target `elem` (reachable n gr)) (suc gr source)
+    findRevertableNodes' gr source target
+      | source == target = if outdeg gr source > 1 then ([], StopRevert) else ([source], ContinueRevert)
+      | otherwise = case findNextNodeInPath gr source target of
+        (Just node) -> case findRevertableNodes' gr node target of
+          (res, StopRevert) -> (res, StopRevert)
+          (res, ContinueRevert) -> if outdeg gr source > 1 then (res, StopRevert) else (source : res, ContinueRevert)
+        Nothing -> ([], ContinueRevert)
+
+revert :: Ref -> Explorer p m c o -> Maybe (Explorer p m c o)
+revert r e
+  | currRef e `elem` reachNodes =
+      jump r e >>= \e' -> return $ e' { execEnv = mkGraph (zip remainNodes remainNodes) $ cleanEdges reachNodes (labEdges $ execEnv e')
+                                      ,  cmap = deleteMap reachNodes (cmap e')
+                                      , shadowExecEnv = cleanShadowEnv (shadowing e') reachNodes (shadowExecEnv e')}
+  | otherwise = Nothing
+  where
+    reachNodes = findRevertableNodes gr r (currRef e)
+    remainNodes = nodes gr \\ reachNodes
+    gr = execEnv e
+
+jump :: Ref -> Explorer p m c o -> Maybe (Explorer p m c o)
+jump r e = case deref e r of
+             (Just c) -> return $ e { config = c, currRef = r }
+             Nothing -> Nothing
+
+toTree :: Explorer p m c o -> Tree (Ref, c)
+toTree exp = mkTree initialRef
+  where graph = execEnv exp
+        target (_, r, _) = r
+        mkTree r = Node (r, cmap exp IntMap.! r) (map (mkTree . target) (out graph r))
+
+
+incomingEdges :: Ref -> Explorer p m c o -> [((Ref, c), (p, o), (Ref, c))]
+incomingEdges ref e = foldr (\(s, t, l) acc ->  [((s, unpack s), l, (t, unpack t))] ++ acc) [] (filter (\(_, t, _) -> t == ref) (labEdges (execEnv e)))
+  where
+    unpack ref = fromJust $ deref e ref
+
+getTrace :: Explorer p m c o -> [((Ref, c), (p, o), (Ref, c))]
+getTrace e = getPathFromTo e initialRef (currRef e)
+
+getTraces :: Explorer p m c o -> [[((Ref, c), (p, o), (Ref, c))]]
+getTraces e = getPathsFromTo e initialRef (currRef e)
+
+
+mapOut :: Explorer p m c o -> Gr Ref (p, o) -> [Ref] -> Ref -> (Ref, Ref, (p,o)) -> Maybe [[((Ref, c), (p, o), (Ref, c))]]
+mapOut exp gr visited goal (s, t, (l, o))
+  | goal == t = Just $ [[((s, unpack s), (l, o), (t, unpack t))]] ++ explore
+  | otherwise = case t `elem` visited of
+                  True -> Nothing
+                  False -> Just explore
+  where
+    explore = map ((:)((s, unpack s), (l, o), (t, unpack t))) (concat $ catMaybes $ map (mapOut exp gr (t : visited) goal) (out gr t))
+    unpack ref = fromJust $ deref exp ref
+
+
+getPathsFromTo :: Explorer p m c o -> Ref -> Ref -> [[((Ref, c), (p, o), (Ref, c))]]
+getPathsFromTo exp from to = concat $ catMaybes $ map (mapOut exp (execEnv exp) [from] to) (out (execEnv exp) from)
+
+getPathFromTo :: Explorer p m c o -> Ref -> Ref -> [((Ref, c), (p, o), (Ref, c))]
+getPathFromTo exp from to =
+  case getPathsFromTo exp from to of
+    [] -> []
+    (x:_) -> x
+
+
+
+executionGraph :: Explorer p m c o -> ((Ref, c), [(Ref, c)], [((Ref, c), (p, o), (Ref, c))])
+executionGraph exp =
+  (curr, nodes, edges)
+  where
+    curr = (currRef exp, config exp)
+    nodes = IntMap.toList $ cmap exp
+    edges = map (\(s, t, p) -> ((s, fromJust $ deref exp s), p, (t, fromJust $ deref exp t)) ) (labEdges (execEnv exp))
+
+{-|
+  Returns all configurations that have not been the source for an execute action.
+  This corresponds to leaves in a tree or nodes without an outbound-edge in a graph.
+-}
+leaves :: Explorer p m c o -> [(Ref, c)]
+leaves exp = map refToPair leaf_nodes
+  where
+    env = execEnv exp
+    refToPair = \r -> (r, fromJust $ deref exp r)
+    leaf_nodes = nodes $ nfilter (\n -> (==0) $ outdeg env n) env
+
+
+toExport :: Explorer p m c o -> (Ref, [(Ref, c)], [(Ref, Ref, (p, o))])
+toExport exp = (currRef exp, IntMap.toList $ cmap exp, labEdges $ execEnv exp)
+
+fromExport :: Explorer p m c o -> (Ref, [(Ref, c)], [(Ref, Ref, (p, o))]) -> Explorer p m c o
+fromExport exp (curr, nds, edgs) = exp { genRef = findMax nds,
+                                         config = findCurrentConf curr nds,
+                                         currRef = curr,
+                                         cmap = IntMap.fromList nds,
+                                         execEnv = mkGraph (map (\(x, _) -> (x, x)) nds) edgs }
+  where findMax l = maximum $ map fst l
+        findCurrentConf curr nds = case lookup curr nds of
+                                     Just conf -> conf
+                                     Nothing   -> error "no config found"
+
+eqClasses :: Explorer p m c o -> [[Ref]]
+eqClasses expl = map snd $ labNodes $ shadowExecEnv expl

@@ -1,91 +1,95 @@-{-# LANGUAGE ConstraintKinds #-}--module Language.Explorer.Pure-    ( Explorer-    , mkExplorer-    , mkExplorerNoSharing-    , execute-    , executeAll-    , revert-    , ExplorerM.toTree-    , incomingEdges-    , config-    , currRef-    , Ref-    , deref-    , leaves-    , getTrace-    , getTraces-    , getPathsFromTo-    , getPathFromTo-    , executionGraph-    , fromExport-    , toExport-    ) where--import qualified Language.Explorer.Monadic as ExplorerM-import Control.Monad.Identity--import qualified Data.IntMap as IntMap-import Data.List-import Data.Foldable---- We shadow instead of exporting directly to make the user interaction--- the same.-type Ref = ExplorerM.Ref-type Explorer a b o = ExplorerM.Explorer a Identity b o-type PureLanguage p c o = (Eq p, Eq o, Monoid o)--mkExplorer :: PureLanguage p c o => Bool -> (c -> c -> Bool) -> (p -> c -> (Maybe c, o)) -> c -> Explorer p c o-mkExplorer shadowing eqfunc definterp initialConf = ExplorerM.mkExplorer shadowing eqfunc (wrap definterp) initialConf--mkExplorerNoSharing :: PureLanguage p c o => (p -> c -> (Maybe c, o)) -> c -> Explorer p c o-mkExplorerNoSharing = mkExplorer False (const . const $ False)--currRef :: Explorer a b o -> Ref-currRef = ExplorerM.currRef--config :: Explorer a b o -> b-config = ExplorerM.config--deref :: Explorer p c o -> Ref -> Maybe c-deref = ExplorerM.deref--wrap :: (Monad m, Monoid o) => (a -> b -> (Maybe b, o)) -> a -> b -> m (Maybe b, o)-wrap def p e = return $ def p e--execute :: PureLanguage p c o =>  p -> Explorer p c o -> (Explorer p c o, o)-execute p e = runIdentity $ ExplorerM.execute p e--executeAll :: PureLanguage p c o => [p] -> Explorer p c o -> (Explorer p c o, o)-executeAll p e = runIdentity $ ExplorerM.executeAll p e--revert :: ExplorerM.Ref -> Explorer p c o -> Maybe (Explorer p c o)-revert = ExplorerM.revert--incomingEdges :: Ref -> Explorer p c o -> [((Ref, c), (p, o), (Ref, c))]-incomingEdges = ExplorerM.incomingEdges--getTrace :: Explorer p c o -> [((Ref, c), (p, o), (Ref, c))]-getTrace = ExplorerM.getTrace--getTraces :: Explorer p c o -> [[((Ref, c), (p, o), (Ref, c))]]-getTraces = ExplorerM.getTraces--getPathsFromTo :: Explorer p c o -> Ref -> Ref -> [[((Ref, c), (p, o), (Ref, c))]]-getPathsFromTo = ExplorerM.getPathsFromTo--getPathFromTo :: Explorer p c o -> Ref -> Ref -> [((Ref, c), (p, o), (Ref, c))]-getPathFromTo = ExplorerM.getPathFromTo--executionGraph :: Explorer p c o -> ((Ref, c), [(Ref, c)], [((Ref, c), (p, o), (Ref, c))])-executionGraph = ExplorerM.executionGraph--leaves :: Explorer p c o -> [(Ref, c)]-leaves = ExplorerM.leaves--toExport :: Explorer p c o -> (Ref, [(Ref, c)], [(Ref, Ref, (p, o))])-toExport = ExplorerM.toExport--fromExport :: Explorer p c o -> (Ref, [(Ref, c)], [(Ref, Ref, (p, o))]) -> Explorer p c o+{-# LANGUAGE ConstraintKinds #-}
+
+module Language.Explorer.Pure
+    ( Explorer
+    , mkExplorer
+    , mkExplorerNoSharing
+    , execute
+    , executeAll
+    , revert
+    , jump
+    , ExplorerM.toTree
+    , incomingEdges
+    , config
+    , currRef
+    , Ref
+    , deref
+    , leaves
+    , getTrace
+    , getTraces
+    , getPathsFromTo
+    , getPathFromTo
+    , executionGraph
+    , fromExport
+    , toExport
+    ) where
+
+import qualified Language.Explorer.Monadic as ExplorerM
+import Control.Monad.Identity
+
+import qualified Data.IntMap as IntMap
+import Data.List
+import Data.Foldable
+
+-- We shadow instead of exporting directly to make the user interaction
+-- the same.
+type Ref = ExplorerM.Ref
+type Explorer a b o = ExplorerM.Explorer a Identity b o
+type PureLanguage p c o = (Eq p, Eq o, Monoid o)
+
+mkExplorer :: PureLanguage p c o => Bool -> (c -> c -> Bool) -> (p -> c -> (Maybe c, o)) -> c -> Explorer p c o
+mkExplorer shadowing eqfunc definterp initialConf = ExplorerM.mkExplorer shadowing eqfunc (wrap definterp) initialConf
+
+mkExplorerNoSharing :: PureLanguage p c o => (p -> c -> (Maybe c, o)) -> c -> Explorer p c o
+mkExplorerNoSharing = mkExplorer False (const . const $ False)
+
+currRef :: Explorer a b o -> Ref
+currRef = ExplorerM.currRef
+
+config :: Explorer a b o -> b
+config = ExplorerM.config
+
+deref :: Explorer p c o -> Ref -> Maybe c
+deref = ExplorerM.deref
+
+wrap :: (Monad m, Monoid o) => (a -> b -> (Maybe b, o)) -> a -> b -> m (Maybe b, o)
+wrap def p e = return $ def p e
+
+execute :: PureLanguage p c o =>  p -> Explorer p c o -> (Explorer p c o, o)
+execute p e = runIdentity $ ExplorerM.execute p e
+
+executeAll :: PureLanguage p c o => [p] -> Explorer p c o -> (Explorer p c o, o)
+executeAll p e = runIdentity $ ExplorerM.executeAll p e
+
+revert :: ExplorerM.Ref -> Explorer p c o -> Maybe (Explorer p c o)
+revert = ExplorerM.revert
+
+jump :: ExplorerM.Ref -> Explorer p c o -> Maybe (Explorer p c o)
+jump = ExplorerM.jump
+
+incomingEdges :: Ref -> Explorer p c o -> [((Ref, c), (p, o), (Ref, c))]
+incomingEdges = ExplorerM.incomingEdges
+
+getTrace :: Explorer p c o -> [((Ref, c), (p, o), (Ref, c))]
+getTrace = ExplorerM.getTrace
+
+getTraces :: Explorer p c o -> [[((Ref, c), (p, o), (Ref, c))]]
+getTraces = ExplorerM.getTraces
+
+getPathsFromTo :: Explorer p c o -> Ref -> Ref -> [[((Ref, c), (p, o), (Ref, c))]]
+getPathsFromTo = ExplorerM.getPathsFromTo
+
+getPathFromTo :: Explorer p c o -> Ref -> Ref -> [((Ref, c), (p, o), (Ref, c))]
+getPathFromTo = ExplorerM.getPathFromTo
+
+executionGraph :: Explorer p c o -> ((Ref, c), [(Ref, c)], [((Ref, c), (p, o), (Ref, c))])
+executionGraph = ExplorerM.executionGraph
+
+leaves :: Explorer p c o -> [(Ref, c)]
+leaves = ExplorerM.leaves
+
+toExport :: Explorer p c o -> (Ref, [(Ref, c)], [(Ref, Ref, (p, o))])
+toExport = ExplorerM.toExport
+
+fromExport :: Explorer p c o -> (Ref, [(Ref, c)], [(Ref, Ref, (p, o))]) -> Explorer p c o
 fromExport = ExplorerM.fromExport

@@ -1,450 +1,450 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE MultiParamTypeClasses #-}----module Language.Explorer.Tools.Protocol where--import GHC.Generics-import Data.Monoid-import Data.Aeson-import Network.HTTP.Types.Status-import Network.HTTP.Types.Header (hContentType)-import Data.Maybe-import Control.Concurrent (forkFinally)-import qualified Control.Exception as E-import Control.Monad (unless, forever, void)-import qualified Data.ByteString.Lazy as S-import qualified Data.Attoparsec.ByteString.Lazy as AB-import qualified Data.Attoparsec.ByteString.Char8 as ABC-import Network.Socket hiding (recv)-import Network.Socket.ByteString.Lazy (recv, sendAll)-import Data.Scientific-import qualified Language.Explorer.Monadic as Ex-import Control.Monad.RWS.Lazy hiding (listen)-import Control.Monad.Trans.Except-import Data.List--type ExplorerParser p m c o = (Ex.Explorer p m c o, String -> Maybe p)-type ProcessResult = Either ErrorMessage Value--type EIP p m c o = RWST (String -> Maybe p) S.ByteString (Ex.Explorer p m c o) m--class ExplorerPostValue p c o where-    postExecute :: Ex.Explorer p m c o -> Ex.Explorer p m c o -> o -> Value-    postExecute = \_ _ _ -> Null-    postJump :: Ex.Explorer p m c o -> Ex.Explorer p m c o -> Value-    postJump = \_ _ -> Null-    postRevert :: Ex.Explorer p m c o -> Ex.Explorer p m c o -> [Ex.Ref] -> Value-    postRevert = \ _ _ _ -> Null--data RequestMessage = RequestMessage {-    jsonrpc :: String,-    req_id :: String,-    method :: String,-    params :: Maybe Value-} deriving (Show, Generic)--instance ToJSON RequestMessage where-    toEncoding = genericToEncoding defaultOptions--instance FromJSON RequestMessage where-    parseJSON = withObject "RequestMessage" $ \v -> RequestMessage-        <$> v .: "jsonrpc"-        <*> v .: "id"-        <*> v .: "method"-        <*> v .:? "params"--data ResponseMessage = ResponseMessage {-    res_id :: String,-    body :: ProcessResult-} deriving (Show)--instance ToJSON ResponseMessage where-    toJSON (ResponseMessage res_id (Left e)) = object ["id" .= res_id, "error" .= e]-    toJSON (ResponseMessage res_id (Right res)) = object ["id" .= res_id, "result" .= res]--    toEncoding (ResponseMessage res_id (Left e)) = pairs ("id" .= res_id <> "error" .= e)-    toEncoding (ResponseMessage res_id (Right res)) = pairs ("id" .= res_id <> "result" .= res)---data ErrorMessage = ErrorMessage {-    code :: Int,-    message :: String,-    error_data :: Maybe Value-} deriving (Show, Generic)--instance ToJSON ErrorMessage where-    toEncoding = genericToEncoding defaultOptions--instance FromJSON ErrorMessage-    -- No need to provide a parseJSON implementation.---- instance Except ErrorMessage --- where---     noMsg = ErrorMessage { code = 0, message = "", error_data = Nothing}---     strMsg msg = ErrorMessage {code = 0, message = msg, error_data = Nothing }--data JumpParams = JumpParams {-    jump_ref :: Int-}--instance FromJSON JumpParams where-    parseJSON = withObject "JumpParams" $ \v -> JumpParams-        <$> v .: "reference"--data JumpResult = JumpResult {-    jump_post :: Value-}--instance ToJSON JumpResult where -    toJSON res = object ["post" .= jump_post res]--data ExecuteParams = ExecuteParams {-    paramsProgram :: String-} deriving (Show, Generic)--instance FromJSON ExecuteParams--data ExecuteResult = ExecuteResult {-    exec_ref :: Int,-    exec_out :: Value,-    exec_post :: Value-}--instance ToJSON ExecuteResult where-    toJSON (ExecuteResult ref out post) = object ["reference" .= ref, "output" .= out, "post" .= post]--    toEncoding (ExecuteResult ref out post) = pairs ("reference" .= ref <> "output" .= out <> "post" .= post)--data RevertParams = RevertParams {-    revert_ref :: Int-}--instance FromJSON RevertParams where-    parseJSON = withObject "RevertParams" $ \v -> RevertParams-        <$> v .: "reference"--data RevertResult = RevertResult {-    revert_deleted :: [Ex.Ref],-    post_revert :: Value-}--instance ToJSON RevertResult where -    toJSON res = object ["deleted" .= revert_deleted res, "post" .= post_revert res]--data DerefParams = DerefParams {-    deref_ref :: Int-}--instance FromJSON DerefParams where-    parseJSON = withObject "DerefParams" $ \v -> DerefParams-        <$> v .: "reference"---data TraceParams = TraceParams {-    reference :: Int-} deriving (Generic)--instance FromJSON TraceParams---data Edge = Edge {-    source :: Int,-    target :: Int,-    label  :: EdgeLabel-} deriving (Generic)--instance ToJSON Edge where-    toEncoding = genericToEncoding defaultOptions---data EdgeLabel = EdgeLabel {-    program :: Value,-    mval :: Value-} deriving (Generic)--instance ToJSON EdgeLabel where-    toEncoding = genericToEncoding defaultOptions---data ExecutionTree = ExecutionTree {-    current :: Int,-    references :: [Int],-    edges :: [Edge]-} deriving (Generic)--instance ToJSON ExecutionTree where-    toEncoding = genericToEncoding defaultOptions--data PathParams = PathParams {-    paramsSource :: Int,-    paramsTarget :: Int-} deriving (Generic)--instance FromJSON PathParams--parseErrorCode = -32700-invalidRequestCode = -32600-methodNotFoundCode = -32601-invalidParamsCode = -32602-internalErrorCode = -32603--referenceNotInTreeCode = 1-referenceRevertInvalidCode = 2-programParseErrorCode = 3-pathNonExistingCode = 4----parseError :: ErrorMessage-parseError = ErrorMessage {-    code = parseErrorCode,-    message = "Parse error",-    error_data = Nothing-}--methodNotFound :: ErrorMessage-methodNotFound = ErrorMessage {-    code = methodNotFoundCode,-    message = "Method not found",-    error_data = Nothing-}--invalidParams :: ErrorMessage-invalidParams = ErrorMessage {-    code = invalidParamsCode,-    message = "Invalid method parameter(s)",-    error_data = Nothing-}--ensureParameter :: Monad m => Maybe Value -> ExceptT ErrorMessage (EIP p m c o) Value-ensureParameter Nothing = throwE invalidParams-ensureParameter (Just v) = return v--fromResult :: Monad m => Result a -> Value -> ExceptT ErrorMessage (EIP p m c o) Value-fromResult res onSuccess = case res of-    (Error e) -> throwE invalidParams-    (Success v) -> return onSuccess--jump :: (Monad m, ExplorerPostValue p c o) => Value -> ExceptT ErrorMessage (EIP p m c o) Value-jump v = case (fromJSON v) :: Result JumpParams of-    (Error e) -> throwE invalidParams-    (Success v') -> do-        ex <- lift $ get-        case Ex.jump (jump_ref v') ex of-            Just ex' -> do-                lift $ put $ ex'-                return . toJSON . JumpResult $ postJump ex ex'-            Nothing -> throwE ErrorMessage { code = referenceNotInTreeCode, message = "", error_data = Nothing }--execute :: (Eq o, Monoid o, ToJSON o, Eq p, ExplorerPostValue p c o) => Value -> ExceptT ErrorMessage (EIP p IO c o) Value-execute v = case (fromJSON v) :: Result ExecuteParams of-    (Error e) -> throwE invalidParams-    (Success v') -> do-        parser <- lift $ ask-        let pl = parser $ paramsProgram v'-        case pl of-            Just prog -> do-                ex <- lift $ get-                (ex', output) <- liftIO $ Ex.execute prog ex-                lift $ put ex'-                return $ toJSON $ ExecuteResult { exec_ref = Ex.currRef ex', exec_out = toJSON output, exec_post = postExecute ex ex' output }-            Nothing -> throwE ErrorMessage { code = programParseErrorCode, message = "", error_data = Nothing }--allRefs :: Ex.Explorer p IO c o -> [(Ex.Ref, c)]-allRefs ex = refs-    where-        (_, refs, _) = Ex.executionGraph ex---revert :: (Eq o, Monoid o, Eq p, ExplorerPostValue p c o) => Value -> ExceptT ErrorMessage (EIP p IO c o) Value-revert v = case (fromJSON v) :: Result RevertParams of-    (Error e) -> throwE invalidParams-    (Success v) -> do-        ex <- lift $ get-        case Ex.revert (revert_ref v) ex of-            Just ex' -> do-                lift $ put ex'-                return $ toJSON $ RevertResult { revert_deleted = deleted, post_revert = postRevert ex ex' deleted}-                where -                    refs = map fst (allRefs ex)-                    refs' = map fst (allRefs ex')-                    deleted = (refs \\ refs')-            Nothing -> throwE ErrorMessage { code = referenceRevertInvalidCode, message = "", error_data = Nothing }--deref :: (Eq o, Monoid o, Eq p, ToJSON c) => Value -> ExceptT ErrorMessage (EIP p IO c o) Value-deref v = case (fromJSON v) :: Result DerefParams of-    (Error e) -> throwE invalidParams-    (Success v) -> do-        ex <- lift $ get-        case Ex.deref ex (deref_ref v) of-            (Just conf) -> return $ toJSON conf-            Nothing -> throwE ErrorMessage { code = referenceNotInTreeCode, message = "", error_data = Nothing}--executionTree :: (ToJSON o, ToJSON p) => ExceptT ErrorMessage (EIP p IO c o) Value-executionTree = do-    ex <- lift $ get-    let (curr, nodes, edges) = Ex.executionGraph ex-    return $ toJSON $ ExecutionTree -        { current = fst curr-        , references = map fst nodes-        , edges = map (\(s, (p, o), t) -> Edge { source = fst s-        , label = EdgeLabel { program = toJSON p, mval = toJSON o}-        , target = fst t} ) edges}--getCurrentReference :: ExceptT ErrorMessage (EIP p IO c o) Value-getCurrentReference = do-    ex <- lift $ get-    return $ toJSON $ Ex.currRef ex--getAllReferences :: ExceptT ErrorMessage (EIP p IO c o) Value-getAllReferences = do-    ex <- lift $ get-    return $ toJSON $ map fst (allRefs ex)--getTrace :: (ToJSON p, ToJSON o) => Maybe Value -> ExceptT ErrorMessage (EIP p IO c o) Value-getTrace (Just r) = case (fromJSON r) :: Result TraceParams of-    (Error e) -> throwE invalidParams-    (Success v) -> do-        ex <- lift $ get-        let path = Ex.getPathFromTo ex 1 (reference (v :: TraceParams)) -- Fix hardcode 1(it's initialRef).-        return $ toJSON $ map (\(s, (p, o), t) -> Edge { source = fst s, target = fst t, label = EdgeLabel { program = toJSON p, mval = toJSON o} }) path-getTrace Nothing = do-    ex <- lift $ get-    let trace = Ex.getTrace ex-    return $ toJSON $ map (\(s, (p, o), t) -> Edge { source = fst s, target = fst t, label = EdgeLabel { program = toJSON p, mval = toJSON o} }) trace--getPath :: (ToJSON o, ToJSON p) => Value -> ExceptT ErrorMessage (EIP p IO c o) Value-getPath val = case (fromJSON val) :: Result PathParams of-    (Error e) -> throwE ErrorMessage { code = pathNonExistingCode, message = "", error_data = Nothing}-    (Success v) -> do-        ex <- lift $ get-        let path = Ex.getPathFromTo ex (paramsSource v) (paramsTarget v)-        return $ toJSON $ map (\(s, (p, o), t) -> Edge { source = fst s, target = fst t, label = EdgeLabel { program = toJSON p, mval = toJSON o} }) path--getLeaves :: ExceptT ErrorMessage (EIP p IO c o) Value-getLeaves = do-    ex <- lift $ get-    return $ toJSON $ map fst (Ex.leaves ex)--methodDispatch :: (Eq o, Monoid o, ToJSON o, ToJSON p, Eq p, ToJSON c, ExplorerPostValue p c o) => String -> Maybe Value -> ExceptT ErrorMessage (EIP p IO c o) Value-methodDispatch "jump" mval = ensureParameter mval >>= jump-methodDispatch "execute" mval = ensureParameter mval >>= execute-methodDispatch "revert" mval = ensureParameter mval >>= revert-methodDispatch "deref" mval = ensureParameter mval >>= deref-methodDispatch "getTrace" mval = getTrace mval-methodDispatch "getPath" mval = ensureParameter mval >>= getPath-methodDispatch "getExecutionTree" _ = executionTree-methodDispatch "getCurrentReference" _ = getCurrentReference-methodDispatch "getAllReferences" _ = getAllReferences-methodDispatch "getLeaves" _ = getLeaves-methodDispatch _ _ = throwE methodNotFound--handleRequest :: (Eq o, Monoid o, ToJSON o, ToJSON o, ToJSON p, Eq p, ToJSON c, ExplorerPostValue p c o) => Maybe RequestMessage -> EIP p IO c o ResponseMessage-handleRequest (Just msg) = do-    res <- runExceptT $ methodDispatch (method msg) (params msg)-    return $ ResponseMessage { res_id = req_id msg, body = res }-handleRequest Nothing = return $ ResponseMessage { res_id = "0", body = Left parseError { message = "NOthing" }}---handleRequest' :: (Eq o, Monoid o, ToJSON o, Eq p, ToJSON p, ToJSON c, ExplorerPostValue p c o) => S.ByteString -> EIP p IO c o ResponseMessage-handleRequest' body =-    case decode body of-        (Just m) -> handleRequest m-        Nothing -> return invalidHeader--invalidHeader :: ResponseMessage-invalidHeader = ResponseMessage { res_id = "0", body = Left parseError {message = "Headeer"} }--parseHeader :: AB.Parser (Int, String)-parseHeader = do-    AB.string "Content-Length:"-    AB.skipMany (ABC.char ' ')-    res <- ABC.scientific-    AB.skipMany (ABC.char ' ')-    ABC.char '\r'-    ABC.char '\n'-    ABC.string "Content-Type:"-    AB.skipMany (ABC.char ' ')-    typ <- AB.manyTill ABC.letter_ascii (ABC.char '\r')-    AB.skipMany (ABC.char ' ')-    ABC.char '\n'-    ABC.char '\r'-    ABC.char '\n'-    return $ (fromJust $ ((toBoundedInteger res) :: Maybe Int), typ)---intProg :: Int -> Int -> IO (Maybe Int, ())-intProg x y = do-    putStrLn . show $ y-    return (Just x, ())--intParse :: String -> Maybe Int-intParse _ = Just 1---- TODO: Handle incorrect request.--- TODO: Send correct error messages.-serve :: (Eq o, Monoid o, ToJSON o, Eq p, ToJSON p, ToJSON c, ExplorerPostValue p c o) => String -> Ex.Explorer p IO c o -> (String -> Maybe p) -> IO ()-serve port ex parser = withSocketsDo $ do-    addr <- resolve port-    E.bracket (open addr) close loop-  where-    resolve port = do-        let hints = defaultHints {-                addrFlags = [AI_PASSIVE]-              , addrSocketType = Stream-              }-        addr:_ <- getAddrInfo (Just hints) Nothing (Just port)-        return addr-    open addr = do-        sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)-        setSocketOption sock ReuseAddr 1-        bind sock (addrAddress addr)-        -- If the prefork technique is not used,-        -- set CloseOnExec for the security reasons.-        fd <- fdSocket sock-        setCloseOnExecIfNeeded fd-        listen sock 10-        return sock-    loop sock = forever $ do-        (conn, peer) <- accept sock-        putStrLn $ "Connection from " ++ show peer-        forkFinally (talk ex parser conn) (\_ -> close conn)-    talk ex parser conn = do-        putStrLn "Hello receiving"-        msg <- recv conn 1024-        unless (S.null msg) $ do-            ex' <- acceptCommand ex parser conn msg-            talk ex' parser conn--acceptCommand ex parser conn command = do-    let res = AB.parse parseHeader command-    putStrLn $ show res-    (result, toParse) <- case res of-        (AB.Done rem (val, _)) -> do-            case S.length rem < (fromIntegral val) of-                True -> do-                    msg <- recv conn 1024-                    return (Nothing, S.append command msg)-                False -> do-                    let command = S.take (fromIntegral val) rem-                    putStrLn "-------------------------"-                    putStrLn $ show command-                    putStrLn "-------------------------"-                    out <- runRWST (handleRequest' command) parser ex-                    return (Just out, S.drop (fromIntegral val) rem)-        (AB.Fail _ _ "not enough input") -> do-            msg <- recv conn 1024-            return (Nothing, S.append command msg)-        _ ->  return (Just (invalidHeader, ex, ""), "")-    case result of-        Nothing -> if toParse == "" then return ex else acceptCommand ex parser conn toParse-        Just (resp, ex', log) -> do-            let encoded_resp = encode resp-            let full_resp = S.concat ["Content-Length:", encode $ S.length encoded_resp, "\r\nContent-Type: jrpcei\r\n\r\n", encoded_resp]-            sendAll conn full_resp-            putStrLn $ show full_resp-            putStrLn $ show toParse-            if toParse == "" then return ex' else acceptCommand ex' parser conn toParse+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+
+
+module Language.Explorer.Tools.Protocol where
+
+import GHC.Generics
+import Data.Monoid
+import Data.Aeson
+import Network.HTTP.Types.Status
+import Network.HTTP.Types.Header (hContentType)
+import Data.Maybe
+import Control.Concurrent (forkFinally)
+import qualified Control.Exception as E
+import Control.Monad (unless, forever, void)
+import qualified Data.ByteString.Lazy as S
+import qualified Data.Attoparsec.ByteString.Lazy as AB
+import qualified Data.Attoparsec.ByteString.Char8 as ABC
+import Network.Socket hiding (recv)
+import Network.Socket.ByteString.Lazy (recv, sendAll)
+import Data.Scientific
+import qualified Language.Explorer.Monadic as Ex
+import Control.Monad.RWS.Lazy hiding (listen)
+import Control.Monad.Trans.Except
+import Data.List
+
+type ExplorerParser p m c o = (Ex.Explorer p m c o, String -> Maybe p)
+type ProcessResult = Either ErrorMessage Value
+
+type EIP p m c o = RWST (String -> Maybe p) S.ByteString (Ex.Explorer p m c o) m
+
+class ExplorerPostValue p c o where
+    postExecute :: Ex.Explorer p m c o -> Ex.Explorer p m c o -> o -> Value
+    postExecute = \_ _ _ -> Null
+    postJump :: Ex.Explorer p m c o -> Ex.Explorer p m c o -> Value
+    postJump = \_ _ -> Null
+    postRevert :: Ex.Explorer p m c o -> Ex.Explorer p m c o -> [Ex.Ref] -> Value
+    postRevert = \ _ _ _ -> Null
+
+data RequestMessage = RequestMessage {
+    jsonrpc :: String,
+    req_id :: String,
+    method :: String,
+    params :: Maybe Value
+} deriving (Show, Generic)
+
+instance ToJSON RequestMessage where
+    toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON RequestMessage where
+    parseJSON = withObject "RequestMessage" $ \v -> RequestMessage
+        <$> v .: "jsonrpc"
+        <*> v .: "id"
+        <*> v .: "method"
+        <*> v .:? "params"
+
+data ResponseMessage = ResponseMessage {
+    res_id :: String,
+    body :: ProcessResult
+} deriving (Show)
+
+instance ToJSON ResponseMessage where
+    toJSON (ResponseMessage res_id (Left e)) = object ["id" .= res_id, "error" .= e]
+    toJSON (ResponseMessage res_id (Right res)) = object ["id" .= res_id, "result" .= res]
+
+    toEncoding (ResponseMessage res_id (Left e)) = pairs ("id" .= res_id <> "error" .= e)
+    toEncoding (ResponseMessage res_id (Right res)) = pairs ("id" .= res_id <> "result" .= res)
+
+
+data ErrorMessage = ErrorMessage {
+    code :: Int,
+    message :: String,
+    error_data :: Maybe Value
+} deriving (Show, Generic)
+
+instance ToJSON ErrorMessage where
+    toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON ErrorMessage
+    -- No need to provide a parseJSON implementation.
+
+-- instance Except ErrorMessage 
+-- where
+--     noMsg = ErrorMessage { code = 0, message = "", error_data = Nothing}
+--     strMsg msg = ErrorMessage {code = 0, message = msg, error_data = Nothing }
+
+data JumpParams = JumpParams {
+    jump_ref :: Int
+}
+
+instance FromJSON JumpParams where
+    parseJSON = withObject "JumpParams" $ \v -> JumpParams
+        <$> v .: "reference"
+
+data JumpResult = JumpResult {
+    jump_post :: Value
+}
+
+instance ToJSON JumpResult where 
+    toJSON res = object ["post" .= jump_post res]
+
+data ExecuteParams = ExecuteParams {
+    paramsProgram :: String
+} deriving (Show, Generic)
+
+instance FromJSON ExecuteParams
+
+data ExecuteResult = ExecuteResult {
+    exec_ref :: Int,
+    exec_out :: Value,
+    exec_post :: Value
+}
+
+instance ToJSON ExecuteResult where
+    toJSON (ExecuteResult ref out post) = object ["reference" .= ref, "output" .= out, "post" .= post]
+
+    toEncoding (ExecuteResult ref out post) = pairs ("reference" .= ref <> "output" .= out <> "post" .= post)
+
+data RevertParams = RevertParams {
+    revert_ref :: Int
+}
+
+instance FromJSON RevertParams where
+    parseJSON = withObject "RevertParams" $ \v -> RevertParams
+        <$> v .: "reference"
+
+data RevertResult = RevertResult {
+    revert_deleted :: [Ex.Ref],
+    post_revert :: Value
+}
+
+instance ToJSON RevertResult where 
+    toJSON res = object ["deleted" .= revert_deleted res, "post" .= post_revert res]
+
+data DerefParams = DerefParams {
+    deref_ref :: Int
+}
+
+instance FromJSON DerefParams where
+    parseJSON = withObject "DerefParams" $ \v -> DerefParams
+        <$> v .: "reference"
+
+
+data TraceParams = TraceParams {
+    reference :: Int
+} deriving (Generic)
+
+instance FromJSON TraceParams
+
+
+data Edge = Edge {
+    source :: Int,
+    target :: Int,
+    label  :: EdgeLabel
+} deriving (Generic)
+
+instance ToJSON Edge where
+    toEncoding = genericToEncoding defaultOptions
+
+
+data EdgeLabel = EdgeLabel {
+    program :: Value,
+    mval :: Value
+} deriving (Generic)
+
+instance ToJSON EdgeLabel where
+    toEncoding = genericToEncoding defaultOptions
+
+
+data ExecutionTree = ExecutionTree {
+    current :: Int,
+    references :: [Int],
+    edges :: [Edge]
+} deriving (Generic)
+
+instance ToJSON ExecutionTree where
+    toEncoding = genericToEncoding defaultOptions
+
+data PathParams = PathParams {
+    paramsSource :: Int,
+    paramsTarget :: Int
+} deriving (Generic)
+
+instance FromJSON PathParams
+
+parseErrorCode = -32700
+invalidRequestCode = -32600
+methodNotFoundCode = -32601
+invalidParamsCode = -32602
+internalErrorCode = -32603
+
+referenceNotInTreeCode = 1
+referenceRevertInvalidCode = 2
+programParseErrorCode = 3
+pathNonExistingCode = 4
+
+
+
+parseError :: ErrorMessage
+parseError = ErrorMessage {
+    code = parseErrorCode,
+    message = "Parse error",
+    error_data = Nothing
+}
+
+methodNotFound :: ErrorMessage
+methodNotFound = ErrorMessage {
+    code = methodNotFoundCode,
+    message = "Method not found",
+    error_data = Nothing
+}
+
+invalidParams :: ErrorMessage
+invalidParams = ErrorMessage {
+    code = invalidParamsCode,
+    message = "Invalid method parameter(s)",
+    error_data = Nothing
+}
+
+ensureParameter :: Monad m => Maybe Value -> ExceptT ErrorMessage (EIP p m c o) Value
+ensureParameter Nothing = throwE invalidParams
+ensureParameter (Just v) = return v
+
+fromResult :: Monad m => Result a -> Value -> ExceptT ErrorMessage (EIP p m c o) Value
+fromResult res onSuccess = case res of
+    (Error e) -> throwE invalidParams
+    (Success v) -> return onSuccess
+
+jump :: (Monad m, ExplorerPostValue p c o) => Value -> ExceptT ErrorMessage (EIP p m c o) Value
+jump v = case (fromJSON v) :: Result JumpParams of
+    (Error e) -> throwE invalidParams
+    (Success v') -> do
+        ex <- lift $ get
+        case Ex.jump (jump_ref v') ex of
+            Just ex' -> do
+                lift $ put $ ex'
+                return . toJSON . JumpResult $ postJump ex ex'
+            Nothing -> throwE ErrorMessage { code = referenceNotInTreeCode, message = "", error_data = Nothing }
+
+execute :: (Eq o, Monoid o, ToJSON o, Eq p, ExplorerPostValue p c o) => Value -> ExceptT ErrorMessage (EIP p IO c o) Value
+execute v = case (fromJSON v) :: Result ExecuteParams of
+    (Error e) -> throwE invalidParams
+    (Success v') -> do
+        parser <- lift $ ask
+        let pl = parser $ paramsProgram v'
+        case pl of
+            Just prog -> do
+                ex <- lift $ get
+                (ex', output) <- liftIO $ Ex.execute prog ex
+                lift $ put ex'
+                return $ toJSON $ ExecuteResult { exec_ref = Ex.currRef ex', exec_out = toJSON output, exec_post = postExecute ex ex' output }
+            Nothing -> throwE ErrorMessage { code = programParseErrorCode, message = "", error_data = Nothing }
+
+allRefs :: Ex.Explorer p IO c o -> [(Ex.Ref, c)]
+allRefs ex = refs
+    where
+        (_, refs, _) = Ex.executionGraph ex
+
+
+revert :: (Eq o, Monoid o, Eq p, ExplorerPostValue p c o) => Value -> ExceptT ErrorMessage (EIP p IO c o) Value
+revert v = case (fromJSON v) :: Result RevertParams of
+    (Error e) -> throwE invalidParams
+    (Success v) -> do
+        ex <- lift $ get
+        case Ex.revert (revert_ref v) ex of
+            Just ex' -> do
+                lift $ put ex'
+                return $ toJSON $ RevertResult { revert_deleted = deleted, post_revert = postRevert ex ex' deleted}
+                where 
+                    refs = map fst (allRefs ex)
+                    refs' = map fst (allRefs ex')
+                    deleted = (refs \\ refs')
+            Nothing -> throwE ErrorMessage { code = referenceRevertInvalidCode, message = "", error_data = Nothing }
+
+deref :: (Eq o, Monoid o, Eq p, ToJSON c) => Value -> ExceptT ErrorMessage (EIP p IO c o) Value
+deref v = case (fromJSON v) :: Result DerefParams of
+    (Error e) -> throwE invalidParams
+    (Success v) -> do
+        ex <- lift $ get
+        case Ex.deref ex (deref_ref v) of
+            (Just conf) -> return $ toJSON conf
+            Nothing -> throwE ErrorMessage { code = referenceNotInTreeCode, message = "", error_data = Nothing}
+
+executionTree :: (ToJSON o, ToJSON p) => ExceptT ErrorMessage (EIP p IO c o) Value
+executionTree = do
+    ex <- lift $ get
+    let (curr, nodes, edges) = Ex.executionGraph ex
+    return $ toJSON $ ExecutionTree 
+        { current = fst curr
+        , references = map fst nodes
+        , edges = map (\(s, (p, o), t) -> Edge { source = fst s
+        , label = EdgeLabel { program = toJSON p, mval = toJSON o}
+        , target = fst t} ) edges}
+
+getCurrentReference :: ExceptT ErrorMessage (EIP p IO c o) Value
+getCurrentReference = do
+    ex <- lift $ get
+    return $ toJSON $ Ex.currRef ex
+
+getAllReferences :: ExceptT ErrorMessage (EIP p IO c o) Value
+getAllReferences = do
+    ex <- lift $ get
+    return $ toJSON $ map fst (allRefs ex)
+
+getTrace :: (ToJSON p, ToJSON o) => Maybe Value -> ExceptT ErrorMessage (EIP p IO c o) Value
+getTrace (Just r) = case (fromJSON r) :: Result TraceParams of
+    (Error e) -> throwE invalidParams
+    (Success v) -> do
+        ex <- lift $ get
+        let path = Ex.getPathFromTo ex 1 (reference (v :: TraceParams)) -- Fix hardcode 1(it's initialRef).
+        return $ toJSON $ map (\(s, (p, o), t) -> Edge { source = fst s, target = fst t, label = EdgeLabel { program = toJSON p, mval = toJSON o} }) path
+getTrace Nothing = do
+    ex <- lift $ get
+    let trace = Ex.getTrace ex
+    return $ toJSON $ map (\(s, (p, o), t) -> Edge { source = fst s, target = fst t, label = EdgeLabel { program = toJSON p, mval = toJSON o} }) trace
+
+getPath :: (ToJSON o, ToJSON p) => Value -> ExceptT ErrorMessage (EIP p IO c o) Value
+getPath val = case (fromJSON val) :: Result PathParams of
+    (Error e) -> throwE ErrorMessage { code = pathNonExistingCode, message = "", error_data = Nothing}
+    (Success v) -> do
+        ex <- lift $ get
+        let path = Ex.getPathFromTo ex (paramsSource v) (paramsTarget v)
+        return $ toJSON $ map (\(s, (p, o), t) -> Edge { source = fst s, target = fst t, label = EdgeLabel { program = toJSON p, mval = toJSON o} }) path
+
+getLeaves :: ExceptT ErrorMessage (EIP p IO c o) Value
+getLeaves = do
+    ex <- lift $ get
+    return $ toJSON $ map fst (Ex.leaves ex)
+
+methodDispatch :: (Eq o, Monoid o, ToJSON o, ToJSON p, Eq p, ToJSON c, ExplorerPostValue p c o) => String -> Maybe Value -> ExceptT ErrorMessage (EIP p IO c o) Value
+methodDispatch "jump" mval = ensureParameter mval >>= jump
+methodDispatch "execute" mval = ensureParameter mval >>= execute
+methodDispatch "revert" mval = ensureParameter mval >>= revert
+methodDispatch "deref" mval = ensureParameter mval >>= deref
+methodDispatch "getTrace" mval = getTrace mval
+methodDispatch "getPath" mval = ensureParameter mval >>= getPath
+methodDispatch "getExecutionTree" _ = executionTree
+methodDispatch "getCurrentReference" _ = getCurrentReference
+methodDispatch "getAllReferences" _ = getAllReferences
+methodDispatch "getLeaves" _ = getLeaves
+methodDispatch _ _ = throwE methodNotFound
+
+handleRequest :: (Eq o, Monoid o, ToJSON o, ToJSON o, ToJSON p, Eq p, ToJSON c, ExplorerPostValue p c o) => Maybe RequestMessage -> EIP p IO c o ResponseMessage
+handleRequest (Just msg) = do
+    res <- runExceptT $ methodDispatch (method msg) (params msg)
+    return $ ResponseMessage { res_id = req_id msg, body = res }
+handleRequest Nothing = return $ ResponseMessage { res_id = "0", body = Left parseError { message = "NOthing" }}
+
+
+handleRequest' :: (Eq o, Monoid o, ToJSON o, Eq p, ToJSON p, ToJSON c, ExplorerPostValue p c o) => S.ByteString -> EIP p IO c o ResponseMessage
+handleRequest' body =
+    case decode body of
+        (Just m) -> handleRequest m
+        Nothing -> return invalidHeader
+
+invalidHeader :: ResponseMessage
+invalidHeader = ResponseMessage { res_id = "0", body = Left parseError {message = "Headeer"} }
+
+parseHeader :: AB.Parser (Int, String)
+parseHeader = do
+    AB.string "Content-Length:"
+    AB.skipMany (ABC.char ' ')
+    res <- ABC.scientific
+    AB.skipMany (ABC.char ' ')
+    ABC.char '\r'
+    ABC.char '\n'
+    ABC.string "Content-Type:"
+    AB.skipMany (ABC.char ' ')
+    typ <- AB.manyTill ABC.letter_ascii (ABC.char '\r')
+    AB.skipMany (ABC.char ' ')
+    ABC.char '\n'
+    ABC.char '\r'
+    ABC.char '\n'
+    return $ (fromJust $ ((toBoundedInteger res) :: Maybe Int), typ)
+
+
+intProg :: Int -> Int -> IO (Maybe Int, ())
+intProg x y = do
+    putStrLn . show $ y
+    return (Just x, ())
+
+intParse :: String -> Maybe Int
+intParse _ = Just 1
+
+-- TODO: Handle incorrect request.
+-- TODO: Send correct error messages.
+serve :: (Eq o, Monoid o, ToJSON o, Eq p, ToJSON p, ToJSON c, ExplorerPostValue p c o) => String -> Ex.Explorer p IO c o -> (String -> Maybe p) -> IO ()
+serve port ex parser = withSocketsDo $ do
+    addr <- resolve port
+    E.bracket (open addr) close loop
+  where
+    resolve port = do
+        let hints = defaultHints {
+                addrFlags = [AI_PASSIVE]
+              , addrSocketType = Stream
+              }
+        addr:_ <- getAddrInfo (Just hints) Nothing (Just port)
+        return addr
+    open addr = do
+        sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+        setSocketOption sock ReuseAddr 1
+        bind sock (addrAddress addr)
+        -- If the prefork technique is not used,
+        -- set CloseOnExec for the security reasons.
+        fd <- fdSocket sock
+        setCloseOnExecIfNeeded fd
+        listen sock 10
+        return sock
+    loop sock = forever $ do
+        (conn, peer) <- accept sock
+        putStrLn $ "Connection from " ++ show peer
+        forkFinally (talk ex parser conn) (\_ -> close conn)
+    talk ex parser conn = do
+        putStrLn "Hello receiving"
+        msg <- recv conn 1024
+        unless (S.null msg) $ do
+            ex' <- acceptCommand ex parser conn msg
+            talk ex' parser conn
+
+acceptCommand ex parser conn command = do
+    let res = AB.parse parseHeader command
+    putStrLn $ show res
+    (result, toParse) <- case res of
+        (AB.Done rem (val, _)) -> do
+            case S.length rem < (fromIntegral val) of
+                True -> do
+                    msg <- recv conn 1024
+                    return (Nothing, S.append command msg)
+                False -> do
+                    let command = S.take (fromIntegral val) rem
+                    putStrLn "-------------------------"
+                    putStrLn $ show command
+                    putStrLn "-------------------------"
+                    out <- runRWST (handleRequest' command) parser ex
+                    return (Just out, S.drop (fromIntegral val) rem)
+        (AB.Fail _ _ "not enough input") -> do
+            msg <- recv conn 1024
+            return (Nothing, S.append command msg)
+        _ ->  return (Just (invalidHeader, ex, ""), "")
+    case result of
+        Nothing -> if toParse == "" then return ex else acceptCommand ex parser conn toParse
+        Just (resp, ex', log) -> do
+            let encoded_resp = encode resp
+            let full_resp = S.concat ["Content-Length:", encode $ S.length encoded_resp, "\r\nContent-Type: jrpcei\r\n\r\n", encoded_resp]
+            sendAll conn full_resp
+            putStrLn $ show full_resp
+            putStrLn $ show toParse
+            if toParse == "" then return ex' else acceptCommand ex' parser conn toParse

@@ -1,73 +1,73 @@-module Language.Explorer.Tools.REPL where--import Control.Monad.IO.Class (MonadIO(..))-import Language.Explorer.Monadic-    (Explorer(config), execute, revert, jump, toTree)-import qualified System.Console.Haskeline as Hl-import Data.Tree (drawTree)-import Data.Maybe (fromJust, isNothing)-import Data.Char (isSpace)-import Data.List (find, isPrefixOf)-import Text.Read (readMaybe)-import Control.Arrow (Arrow(first))-import Control.Monad.Trans-import Control.Monad.Catch---type MetaTable p m c o = [(String, String -> Explorer p m c o -> m (Explorer p m c o))]-type RParser p c = String -> c -> Maybe p-type Prompt p m c o = Explorer p m c o -> String-type MetaHandler p m c o = String -> Explorer p m c o -> m (Explorer p m c o)-type OutputHandler m o = o -> m ()-type Repl p m c o = Prompt p m c o -> RParser p c -> String -> MetaTable p m c o -> MetaHandler p m c o -> OutputHandler m o -> Explorer p m c o -> m ()---handleJump :: MonadIO m => String -> Explorer p m c o -> m (Explorer p m c o)-handleJump input ex = case readMaybe (dropWhile isSpace input) of-  (Just ref_id) -> case jump ref_id ex of-    (Just ex') -> return ex'-    Nothing -> liftIO $ putStrLn "Given reference is not in the exploration tree." >> return ex-  Nothing -> liftIO $ putStrLn "the jump command requires an integer argument." >> return ex--handleRevert :: MonadIO m => MetaHandler p m c o-handleRevert input ex = case readMaybe (dropWhile isSpace input) of-  (Just ref_id) -> case revert ref_id ex of-    (Just ex') -> do-      liftIO $ putStrLn "reverting"-      return ex'-    Nothing -> liftIO $ putStrLn "Given reference is not valid for reverting." >> return ex-  Nothing -> liftIO $ putStrLn "the jump command requires an integer argument." >> return ex--handleTree :: MonadIO m => MetaHandler p m c o-handleTree input ex = do-  liftIO $ putStrLn . drawTree $ fmap (show . fst) (toTree ex)-  return ex--metaTable :: MonadIO m => [(String, String -> Explorer p m c o -> m (Explorer p m c o))]-metaTable = [-  ("jump", handleJump),-  ("revert", handleRevert),-  ("tree", handleTree)]--constructMetaTable :: MonadIO m => String -> [(String, String -> Explorer p m c o -> m (Explorer p m c o))]-constructMetaTable prefix = map (first (prefix ++ )) metaTable--repl :: (Eq p, Eq o, Monoid o, MonadIO m, MonadMask m) => Repl p m c o-repl prompt parser metaPrefix metaTable metaHandler outputHandler ex =-  Hl.runInputT Hl.defaultSettings (loop ex)-    where-    loop ex = do-      minput <- Hl.getInputLine . prompt $ ex-      case minput of-        (Just input) -> lift (if metaPrefix `isPrefixOf` input then runMeta input else runExec input) >>= loop-        Nothing -> return ()-      where-        runMeta input =-          let (pcmd, args) = break isSpace input in-            case find (\(cmd, _) -> (metaPrefix ++ cmd) == pcmd) metaTable of-              Just (_, f) -> f args ex-              Nothing -> metaHandler input ex-        runExec input =-          case parser input (config ex) of-            (Just program) -> execute program ex >>= \(newEx, out) -> outputHandler out >> return newEx-            Nothing -> return ex+module Language.Explorer.Tools.REPL where
+
+import Control.Monad.IO.Class (MonadIO(..))
+import Language.Explorer.Monadic
+    (Explorer(config), execute, revert, jump, toTree)
+import qualified System.Console.Haskeline as Hl
+import Data.Tree (drawTree)
+import Data.Maybe (fromJust, isNothing)
+import Data.Char (isSpace)
+import Data.List (find, isPrefixOf)
+import Text.Read (readMaybe)
+import Control.Arrow (Arrow(first))
+import Control.Monad.Trans
+import Control.Monad.Catch
+
+
+type MetaTable p m c o = [(String, String -> Explorer p m c o -> m (Explorer p m c o))]
+type RParser p c = String -> c -> Maybe p
+type Prompt p m c o = Explorer p m c o -> String
+type MetaHandler p m c o = String -> Explorer p m c o -> m (Explorer p m c o)
+type OutputHandler m o = o -> m ()
+type Repl p m c o = Prompt p m c o -> RParser p c -> String -> MetaTable p m c o -> MetaHandler p m c o -> OutputHandler m o -> Explorer p m c o -> m ()
+
+
+handleJump :: MonadIO m => String -> Explorer p m c o -> m (Explorer p m c o)
+handleJump input ex = case readMaybe (dropWhile isSpace input) of
+  (Just ref_id) -> case jump ref_id ex of
+    (Just ex') -> return ex'
+    Nothing -> liftIO $ putStrLn "Given reference is not in the exploration tree." >> return ex
+  Nothing -> liftIO $ putStrLn "the jump command requires an integer argument." >> return ex
+
+handleRevert :: MonadIO m => MetaHandler p m c o
+handleRevert input ex = case readMaybe (dropWhile isSpace input) of
+  (Just ref_id) -> case revert ref_id ex of
+    (Just ex') -> do
+      liftIO $ putStrLn "reverting"
+      return ex'
+    Nothing -> liftIO $ putStrLn "Given reference is not valid for reverting." >> return ex
+  Nothing -> liftIO $ putStrLn "the jump command requires an integer argument." >> return ex
+
+handleTree :: MonadIO m => MetaHandler p m c o
+handleTree input ex = do
+  liftIO $ putStrLn . drawTree $ fmap (show . fst) (toTree ex)
+  return ex
+
+metaTable :: MonadIO m => [(String, String -> Explorer p m c o -> m (Explorer p m c o))]
+metaTable = [
+  ("jump", handleJump),
+  ("revert", handleRevert),
+  ("tree", handleTree)]
+
+constructMetaTable :: MonadIO m => String -> [(String, String -> Explorer p m c o -> m (Explorer p m c o))]
+constructMetaTable prefix = map (first (prefix ++ )) metaTable
+
+repl :: (Eq p, Eq o, Monoid o, MonadIO m, MonadMask m) => Repl p m c o
+repl prompt parser metaPrefix metaTable metaHandler outputHandler ex =
+  Hl.runInputT Hl.defaultSettings (loop ex)
+    where
+    loop ex = do
+      minput <- Hl.getInputLine . prompt $ ex
+      case minput of
+        (Just input) -> lift (if metaPrefix `isPrefixOf` input then runMeta input else runExec input) >>= loop
+        Nothing -> return ()
+      where
+        runMeta input =
+          let (pcmd, args) = break isSpace input in
+            case find (\(cmd, _) -> (metaPrefix ++ cmd) == pcmd) metaTable of
+              Just (_, f) -> f args ex
+              Nothing -> metaHandler input ex
+        runExec input =
+          case parser input (config ex) of
+            (Just program) -> execute program ex >>= \(newEx, out) -> outputHandler out >> return newEx
+            Nothing -> return ex

@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple
+main = defaultMain

@@ -1,248 +1,248 @@-module Whilelang where--import qualified Data.Map as Map-import Data.List-import Data.Maybe-import Data.Graph.Inductive (emap)-import Control.Monad.Trans.Writer.Lazy-import Control.Monad.Trans.State.Lazy-import Control.Monad.Trans.Class-import Control.Monad.Identity-import qualified Language.Explorer.Basic as E-import qualified Language.Explorer.Pure as EP-import qualified Language.Explorer.Monadic as EM-import qualified Language.Explorer.Tools.REPL as R-import Language.Explorer.Basic (mkExplorerNoSharing)----data Literal = LitBool Bool | LitInt Integer deriving (Eq, Read)-instance Show Literal where-    show (LitBool b) = show b-    show (LitInt i) = show i--data Expr = Leq Expr Expr | Plus Expr Expr | LitExpr Literal | Id String deriving (Eq, Read)-instance Show Expr where-    show (Leq e1 e2) = show e1 ++ "<=" ++ show e2-    show (Plus e1 e2) = show e1 ++ "+" ++ show e2-    show (LitExpr lit) = show lit-    show (Id s) = s--data Command = Seq Command Command | Assign String Expr | Print Expr | While Expr Expr Command | Done deriving (Eq, Read)-instance Show Command where-    show (Print e1) = "print(" ++ show e1 ++ ")"-    show Done = "Done"-    show (Assign s e) = s ++ " = " ++ show e-    show (Seq c1 c2) = show c1 ++ "\n" ++ show c2-    show (While e1 e2 c) = "while(" ++ show e2 ++ ") do\n" ++ show c ++ "\nod"--type Store = Map.Map String Literal-type StoreM = State Store-type Output = [String]-data Config = Config { cfgStore :: Store, cfgOutput :: Output } deriving (Show, Eq)--type WhileExplorer = E.Explorer Command Config-type WhileExplorerM = EM.Explorer Command IO Config ()-type WhileExplorerO = EP.Explorer Command Config [String]--evalPlus :: Expr -> Expr -> StoreM Expr-evalPlus (LitExpr (LitInt l1)) (LitExpr (LitInt l2)) = return $ LitExpr $ LitInt (l1 + l2)-evalPlus (LitExpr l1) l2 = do-    l2' <- evalExpr l2-    return (Plus (LitExpr l1) l2')-evalPlus l1 l2 = do-    l1' <- evalExpr l1-    return (Plus l1' l2)--evalLeq :: Expr -> Expr -> StoreM Expr-evalLeq (LitExpr (LitInt l1)) (LitExpr (LitInt l2)) = return $ LitExpr $ LitBool (l1 <= l2)-evalLeq (LitExpr l1) e2 = do-    e2' <- evalExpr e2-    return (Leq (LitExpr l1) e2')-evalLeq e1 e2 = do-    e1' <- evalExpr e1-    return (Leq e1' e2)--evalExpr :: Expr -> StoreM Expr-evalExpr (LitExpr e) = return $ LitExpr e-evalExpr (Plus e1 e2) = evalPlus e1 e2-evalExpr (Leq e1 e2) = evalLeq e1 e2-evalExpr (Id s) = do-    m <- get-    let l = Map.lookup s m-    case l of-        Just lit -> return $ LitExpr lit-        Nothing -> error $ "Invalid Id: " ++ s--evalExpr' :: Expr -> StoreM Expr-evalExpr' (LitExpr e) = return $ LitExpr e-evalExpr' e = do-    e' <- evalExpr e-    evalExpr' e'--store :: String -> Expr -> StoreM Command-store s (LitExpr l) = do-    lut <- get-    put $ Map.insert s l lut-    return Done--evalCommand :: Command -> WriterT [String] StoreM Command-evalCommand (Print e) = do-    x <- (lift . evalExpr') e-    tell [show x]-    return Done-evalCommand (Assign id e) = do-    lit <- (lift . evalExpr') e-    lift $ store id lit-evalCommand (Seq Done c2) = return c2-evalCommand (Seq c1 c2) = do-    c1' <- evalCommand c1-    return $ Seq c1' c2-evalCommand (While (LitExpr (LitBool False)) e2 c) = return Done-evalCommand (While (LitExpr (LitBool True)) e2 c) = return $ Seq c (While e2 e2 c)-evalCommand (While e1 e2 c) = do-    e1' <- (lift . evalExpr') e1-    return $ While e1' e2 c---evalCommand' :: Command -> WriterT [String] StoreM Command-evalCommand' Done = return Done-evalCommand' c = do-    c' <- evalCommand c-    evalCommand' c'---- Initial configuration in the while language)-initialConfig :: Config-initialConfig = Config {cfgStore = Map.empty, cfgOutput = []}---- Definitial interpreter for the while language.-definterp :: Command -> Config -> Maybe Config-definterp c cfg = Just cfg {cfgStore = newstore, cfgOutput = cfgOutput cfg ++ newout}-    where ((_, newout), newstore) = runState (runWriterT (evalCommand' c)) (cfgStore cfg)---definterpO :: Command -> Config -> (Maybe Config, [String])-definterpO c cfg = (Just $ cfg {cfgStore = newstore}, newout)-    where ((_, newout), newstore) = runState (runWriterT (evalCommand' c)) (cfgStore cfg)----- Simulate doing IO in the definitional interpreter.-definterpM :: Command -> Config -> IO (Maybe Config, ())-definterpM c cfg = do-    mapM putStrLn newout-    return (Just $ cfg {cfgStore = newstore, cfgOutput = []}, ())-    where ((_, newout), newstore) = runState (runWriterT (evalCommand' c)) (cfgStore cfg)---parser :: String -> c -> Maybe Command-parser s _ = Just (read s :: Command)--repl = R.repl (const "While> ") parser ":" R.metaTable  (\_ ex -> return ex) (\_ -> return ()) (EM.mkExplorerNoSharing definterpM initialConfig)---- whileLang = (Command, Config, initialConfig, definterp)----do_ :: Command -> WhileExplorer -> IO WhileExplorer-do_ (Seq c1 c2) e = do_ c1 e >>= do_ c2-do_ p e = do-    let e' = E.execute p e-    putStr $ unlines $ cfgOutput (E.config e') \\ cfgOutput (E.config e)-    return e'--do_2 :: Command -> WhileExplorerM -> IO WhileExplorerM-do_2 (Seq c1 c2) e = do_2 c1 e >>= do_2 c2-do_2 p e = fst <$> EM.execute p e--do_3 :: Command -> (WhileExplorerO, [String]) -> (WhileExplorerO, [String])-do_3 (Seq c1 c2) e = do_3 c2 $ do_3 c1 e-do_3 p (e, o) = (e', o ++ o')-  where (e', o') = EP.execute p e--start :: IO WhileExplorer-start = return whileExplorer---- startM :: IO WhileExplorerM--- startM = return whileTree---- startO :: WhileExplorerO--- startO = whileGraphO--session1 :: IO WhileExplorer-session1 = start >>=-  do_ (assign "x" (intToExpr 1)) >>=-  do_ (assign "y" (Id "x")) >>=-  do_ (assign "x" (intToExpr 1)) >>=-  do_ (Print (Id "y")) >>=-  do_ (Print (Id "x")) . fromJust . EM.jump 2 >>=-  do_ (assign "z" (intToExpr 100)) >>=-  do_ (Print (Id "z"))---sessionS :: IO WhileExplorer-sessionS = start >>=-  do_ (assign "x" (intToExpr 1)) >>=-  do_ (assign "y" (Id "x")) >>=-  do_ (assign "x" (intToExpr 1)) >>=-  do_ (assign "z" (intToExpr 20)) >>=-  do_ (assign "y" (Id "x"))------ -- When using sharing, this results in 3 configurations and not 4,--- -- since the IO effect is hidden in the monad and not part of the--- -- configurations anymore.--- session2 :: IO WhileExplorerM--- session2 = startM >>=---   do_2 (assign "x" (intToExpr 1)) >>=---   do_2 (assign "y" (Id "x")) >>=---   do_2 (Print (Id "y"))----- session3 :: (WhileExplorerO, [String])--- session3 =---   do_3 (Print (Id "y")) $ do_3 (assign "y" (Id "x")) $ do_3 (assign "x" (intToExpr 1)) (startO, [])---- Below are some helpers to create a Command and fully evaluate it.--- Example:--- ghci> let x = wprint (intToExpr 10) `wseq` (wprint (intToExpr 100) `wseq` wprint (intToExpr 200))--- ghci> runCommand' x--- ["10","100","200"]--- ghci>-runCommand :: Command -> IO()-runCommand c = do-    let ((_, output), _) = runState (runWriterT (evalCommand' c)) Map.empty-    print output---intToExpr :: Integer -> Expr-intToExpr = LitExpr . LitInt--boolToExpr :: Bool -> Expr-boolToExpr = LitExpr . LitBool--while ::  Expr -> Command -> Command-while e = While e e--leq :: Expr -> Expr -> Expr-leq = Leq--wprint :: Expr -> Command-wprint = Print--plus :: Expr -> Expr -> Expr-plus = Plus--assign :: String -> Expr -> Command-assign = Assign--wseq :: Command -> Command -> Command-wseq = Seq--whileExplorer :: WhileExplorer-whileExplorer = E.mkExplorer True (==) definterp initialConfig--whileExample = Seq (Assign "x" (intToExpr 0)) (while (Leq (Id "x") (intToExpr 10)) (Seq (Assign "x" (Plus (Id "x") (intToExpr 1))) (Print (Id "x"))))--zero = intToExpr 0--getRef :: WhileExplorer -> E.Ref-getRef = E.currRef+module Whilelang where
+
+import qualified Data.Map as Map
+import Data.List
+import Data.Maybe
+import Data.Graph.Inductive (emap)
+import Control.Monad.Trans.Writer.Lazy
+import Control.Monad.Trans.State.Lazy
+import Control.Monad.Trans.Class
+import Control.Monad.Identity
+import qualified Language.Explorer.Basic as E
+import qualified Language.Explorer.Pure as EP
+import qualified Language.Explorer.Monadic as EM
+import qualified Language.Explorer.Tools.REPL as R
+import Language.Explorer.Basic (mkExplorerNoSharing)
+
+
+
+data Literal = LitBool Bool | LitInt Integer deriving (Eq, Read)
+instance Show Literal where
+    show (LitBool b) = show b
+    show (LitInt i) = show i
+
+data Expr = Leq Expr Expr | Plus Expr Expr | LitExpr Literal | Id String deriving (Eq, Read)
+instance Show Expr where
+    show (Leq e1 e2) = show e1 ++ "<=" ++ show e2
+    show (Plus e1 e2) = show e1 ++ "+" ++ show e2
+    show (LitExpr lit) = show lit
+    show (Id s) = s
+
+data Command = Seq Command Command | Assign String Expr | Print Expr | While Expr Expr Command | Done deriving (Eq, Read)
+instance Show Command where
+    show (Print e1) = "print(" ++ show e1 ++ ")"
+    show Done = "Done"
+    show (Assign s e) = s ++ " = " ++ show e
+    show (Seq c1 c2) = show c1 ++ "\n" ++ show c2
+    show (While e1 e2 c) = "while(" ++ show e2 ++ ") do\n" ++ show c ++ "\nod"
+
+type Store = Map.Map String Literal
+type StoreM = State Store
+type Output = [String]
+data Config = Config { cfgStore :: Store, cfgOutput :: Output } deriving (Show, Eq)
+
+type WhileExplorer = E.Explorer Command Config
+type WhileExplorerM = EM.Explorer Command IO Config ()
+type WhileExplorerO = EP.Explorer Command Config [String]
+
+evalPlus :: Expr -> Expr -> StoreM Expr
+evalPlus (LitExpr (LitInt l1)) (LitExpr (LitInt l2)) = return $ LitExpr $ LitInt (l1 + l2)
+evalPlus (LitExpr l1) l2 = do
+    l2' <- evalExpr l2
+    return (Plus (LitExpr l1) l2')
+evalPlus l1 l2 = do
+    l1' <- evalExpr l1
+    return (Plus l1' l2)
+
+evalLeq :: Expr -> Expr -> StoreM Expr
+evalLeq (LitExpr (LitInt l1)) (LitExpr (LitInt l2)) = return $ LitExpr $ LitBool (l1 <= l2)
+evalLeq (LitExpr l1) e2 = do
+    e2' <- evalExpr e2
+    return (Leq (LitExpr l1) e2')
+evalLeq e1 e2 = do
+    e1' <- evalExpr e1
+    return (Leq e1' e2)
+
+evalExpr :: Expr -> StoreM Expr
+evalExpr (LitExpr e) = return $ LitExpr e
+evalExpr (Plus e1 e2) = evalPlus e1 e2
+evalExpr (Leq e1 e2) = evalLeq e1 e2
+evalExpr (Id s) = do
+    m <- get
+    let l = Map.lookup s m
+    case l of
+        Just lit -> return $ LitExpr lit
+        Nothing -> error $ "Invalid Id: " ++ s
+
+evalExpr' :: Expr -> StoreM Expr
+evalExpr' (LitExpr e) = return $ LitExpr e
+evalExpr' e = do
+    e' <- evalExpr e
+    evalExpr' e'
+
+store :: String -> Expr -> StoreM Command
+store s (LitExpr l) = do
+    lut <- get
+    put $ Map.insert s l lut
+    return Done
+
+evalCommand :: Command -> WriterT [String] StoreM Command
+evalCommand (Print e) = do
+    x <- (lift . evalExpr') e
+    tell [show x]
+    return Done
+evalCommand (Assign id e) = do
+    lit <- (lift . evalExpr') e
+    lift $ store id lit
+evalCommand (Seq Done c2) = return c2
+evalCommand (Seq c1 c2) = do
+    c1' <- evalCommand c1
+    return $ Seq c1' c2
+evalCommand (While (LitExpr (LitBool False)) e2 c) = return Done
+evalCommand (While (LitExpr (LitBool True)) e2 c) = return $ Seq c (While e2 e2 c)
+evalCommand (While e1 e2 c) = do
+    e1' <- (lift . evalExpr') e1
+    return $ While e1' e2 c
+
+
+evalCommand' :: Command -> WriterT [String] StoreM Command
+evalCommand' Done = return Done
+evalCommand' c = do
+    c' <- evalCommand c
+    evalCommand' c'
+
+-- Initial configuration in the while language)
+initialConfig :: Config
+initialConfig = Config {cfgStore = Map.empty, cfgOutput = []}
+
+-- Definitial interpreter for the while language.
+definterp :: Command -> Config -> Maybe Config
+definterp c cfg = Just cfg {cfgStore = newstore, cfgOutput = cfgOutput cfg ++ newout}
+    where ((_, newout), newstore) = runState (runWriterT (evalCommand' c)) (cfgStore cfg)
+
+
+definterpO :: Command -> Config -> (Maybe Config, [String])
+definterpO c cfg = (Just $ cfg {cfgStore = newstore}, newout)
+    where ((_, newout), newstore) = runState (runWriterT (evalCommand' c)) (cfgStore cfg)
+
+
+-- Simulate doing IO in the definitional interpreter.
+definterpM :: Command -> Config -> IO (Maybe Config, ())
+definterpM c cfg = do
+    mapM putStrLn newout
+    return (Just $ cfg {cfgStore = newstore, cfgOutput = []}, ())
+    where ((_, newout), newstore) = runState (runWriterT (evalCommand' c)) (cfgStore cfg)
+
+
+parser :: String -> c -> Maybe Command
+parser s _ = Just (read s :: Command)
+
+repl = R.repl (const "While> ") parser ":" R.metaTable  (\_ ex -> return ex) (\_ -> return ()) (EM.mkExplorerNoSharing definterpM initialConfig)
+
+-- whileLang = (Command, Config, initialConfig, definterp)
+--
+do_ :: Command -> WhileExplorer -> IO WhileExplorer
+do_ (Seq c1 c2) e = do_ c1 e >>= do_ c2
+do_ p e = do
+    let e' = E.execute p e
+    putStr $ unlines $ cfgOutput (E.config e') \\ cfgOutput (E.config e)
+    return e'
+
+do_2 :: Command -> WhileExplorerM -> IO WhileExplorerM
+do_2 (Seq c1 c2) e = do_2 c1 e >>= do_2 c2
+do_2 p e = fst <$> EM.execute p e
+
+do_3 :: Command -> (WhileExplorerO, [String]) -> (WhileExplorerO, [String])
+do_3 (Seq c1 c2) e = do_3 c2 $ do_3 c1 e
+do_3 p (e, o) = (e', o ++ o')
+  where (e', o') = EP.execute p e
+
+start :: IO WhileExplorer
+start = return whileExplorer
+
+-- startM :: IO WhileExplorerM
+-- startM = return whileTree
+
+-- startO :: WhileExplorerO
+-- startO = whileGraphO
+
+session1 :: IO WhileExplorer
+session1 = start >>=
+  do_ (assign "x" (intToExpr 1)) >>=
+  do_ (assign "y" (Id "x")) >>=
+  do_ (assign "x" (intToExpr 1)) >>=
+  do_ (Print (Id "y")) >>=
+  do_ (Print (Id "x")) . fromJust . EM.jump 2 >>=
+  do_ (assign "z" (intToExpr 100)) >>=
+  do_ (Print (Id "z"))
+
+
+sessionS :: IO WhileExplorer
+sessionS = start >>=
+  do_ (assign "x" (intToExpr 1)) >>=
+  do_ (assign "y" (Id "x")) >>=
+  do_ (assign "x" (intToExpr 1)) >>=
+  do_ (assign "z" (intToExpr 20)) >>=
+  do_ (assign "y" (Id "x"))
+
+
+
+-- -- When using sharing, this results in 3 configurations and not 4,
+-- -- since the IO effect is hidden in the monad and not part of the
+-- -- configurations anymore.
+-- session2 :: IO WhileExplorerM
+-- session2 = startM >>=
+--   do_2 (assign "x" (intToExpr 1)) >>=
+--   do_2 (assign "y" (Id "x")) >>=
+--   do_2 (Print (Id "y"))
+
+
+-- session3 :: (WhileExplorerO, [String])
+-- session3 =
+--   do_3 (Print (Id "y")) $ do_3 (assign "y" (Id "x")) $ do_3 (assign "x" (intToExpr 1)) (startO, [])
+
+-- Below are some helpers to create a Command and fully evaluate it.
+-- Example:
+-- ghci> let x = wprint (intToExpr 10) `wseq` (wprint (intToExpr 100) `wseq` wprint (intToExpr 200))
+-- ghci> runCommand' x
+-- ["10","100","200"]
+-- ghci>
+runCommand :: Command -> IO()
+runCommand c = do
+    let ((_, output), _) = runState (runWriterT (evalCommand' c)) Map.empty
+    print output
+
+
+intToExpr :: Integer -> Expr
+intToExpr = LitExpr . LitInt
+
+boolToExpr :: Bool -> Expr
+boolToExpr = LitExpr . LitBool
+
+while ::  Expr -> Command -> Command
+while e = While e e
+
+leq :: Expr -> Expr -> Expr
+leq = Leq
+
+wprint :: Expr -> Command
+wprint = Print
+
+plus :: Expr -> Expr -> Expr
+plus = Plus
+
+assign :: String -> Expr -> Command
+assign = Assign
+
+wseq :: Command -> Command -> Command
+wseq = Seq
+
+whileExplorer :: WhileExplorer
+whileExplorer = E.mkExplorer True (==) definterp initialConfig
+
+whileExample = Seq (Assign "x" (intToExpr 0)) (while (Leq (Id "x") (intToExpr 10)) (Seq (Assign "x" (Plus (Id "x") (intToExpr 1))) (Print (Id "x"))))
+
+zero = intToExpr 0
+
+getRef :: WhileExplorer -> E.Ref
+getRef = E.currRef

@@ -1,48 +1,48 @@-cabal-version:       >=1.10--name:                exploring-interpreters-version:             1.5.0.1-synopsis:            A generic exploring interpreter for exploratory programming--- synopsis:--- description:--- bug-reports:-license:             BSD3-license-file:        LICENSE-author:              Damian Frolich-maintainer:          leegbestand@gmail.com--- copyright:-category:            Compilers/Interpreters-build-type:          Simple-extra-source-files:  CHANGELOG.md examples/Whilelang.hs--source-repository head-    type:         git-    location:     https://github.com/leegbestand/exploring_interpreters--library-  exposed-modules:-      Language.Explorer.Monadic,-      Language.Explorer.Pure,-      Language.Explorer.Tools.REPL,-      Language.Explorer.Tools.Protocol-  other-modules:-      Language.Explorer.Basic-  -- other-extensions:-  build-depends:-      base >=4.9 && <5,-      containers >=0.5 && <0.7,-      fgl >= 5.7.0 && < 5.9,-      transformers >= 0.5.2 && < 0.6,-      mtl          >= 2.2.1 && < 2.3,-      aeson                 >= 2.2.1 && < 2.3,-      attoparsec            >= 0.14.1 && < 0.15,-      bytestring            >= 0.10.10 && < 0.12,-      scientific            >= 0.3.7 && < 0.4,-      text                  >= 2.1 && < 2.2,-      http-types            >= 0.12.3 && < 0.13,-      network               >= 3.1.2 && < 3.2,-      haskeline             >=0.8.2 && < 0.9,-      exceptions            >=0.10.4 && < 0.11--  -- hs-source-dirs:-  default-language:    Haskell2010+cabal-version:       >=1.10
+
+name:                exploring-interpreters
+version:             1.6.0.0
+synopsis:            A generic exploring interpreter for exploratory programming
+-- synopsis:
+-- description:
+-- bug-reports:
+license:             BSD3
+license-file:        LICENSE
+author:              Damian Frolich
+maintainer:          leegbestand@gmail.com
+-- copyright:
+category:            Compilers/Interpreters
+build-type:          Simple
+extra-source-files:  CHANGELOG.md examples/Whilelang.hs
+
+source-repository head
+    type:         git
+    location:     https://github.com/leegbestand/exploring_interpreters
+
+library
+  exposed-modules:
+      Language.Explorer.Monadic,
+      Language.Explorer.Pure,
+      Language.Explorer.Tools.REPL,
+      Language.Explorer.Tools.Protocol
+  other-modules:
+      Language.Explorer.Basic
+  -- other-extensions:
+  build-depends:
+      base >=4.9 && <5,
+      containers >=0.5 && <1,
+      fgl >= 5.7.0 && < 6,
+      transformers >= 0.5.2 && < 1,
+      mtl          >= 2.2.1 && < 3,
+      aeson                 >= 2.2.1 && < 3,
+      attoparsec            >= 0.14.1 && < 1,
+      bytestring            >= 0.10.10 && < 1,
+      scientific            >= 0.3.7 && < 1,
+      text                  >= 2.1 && <3,
+      http-types            >= 0.12.3 && < 1,
+      network               >= 3.1.2 && <4,
+      haskeline             >=0.8.2 && < 1,
+      exceptions            >=0.10.4 && < 1
+
+  -- hs-source-dirs:
+  default-language:    Haskell2010