Commit 07cd4603 authored by Sebastian Erdweg's avatar Sebastian Erdweg

progress toward migrating Stratego AI to current library

parent ca98ab9c
......@@ -73,7 +73,7 @@ instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowStore var val c) => Arrow
read (ExceptT f) (ExceptT g) = ExceptT $ read f g
write = lift write
instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowFail e c) => ArrowFail e (ExceptT e c) where
instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowFail f c) => ArrowFail f (ExceptT e c) where
fail = lift fail
instance (Complete e, ArrowJoin c, ArrowChoice c, ArrowReader r c) => ArrowReader r (ExceptT e c) where
......
......@@ -20,6 +20,7 @@ import Control.Arrow.Lift
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Except as Exc
import Control.Arrow.Abstract.Join
import Control.Category
import Data.Abstract.Failure
......@@ -28,7 +29,7 @@ import Data.Monoidal
import Data.Identifiable
-- | Describes computations that can fail.
newtype FailureT e c x y = FailureT { runFailureT :: c x (Error e y) }
newtype FailureT e c x y = FailureT { runFailureT :: c x (Failure e y) }
instance ArrowLift (FailureT e) where
lift f = FailureT (f >>> arr Success)
......@@ -70,30 +71,38 @@ instance (ArrowChoice c, ArrowReader r c) => ArrowReader r (FailureT e c) where
local (FailureT f) = FailureT (local f)
instance (ArrowChoice c, ArrowEnv var val env c) => ArrowEnv var val env (FailureT e c) where
type Join (FailureT e c) x y = Env.Join c x (Error e y)
type Join (FailureT e c) x y = Env.Join c x (Failure e y)
lookup (FailureT f) (FailureT g) = FailureT $ lookup f g
getEnv = lift getEnv
extendEnv = lift extendEnv
localEnv (FailureT f) = FailureT (localEnv f)
type instance Fix x y (FailureT e c) = FailureT e (Fix x (Error e y) c)
instance (ArrowChoice c, ArrowFix x (Error e y) c) => ArrowFix x y (FailureT e c) where
type instance Fix x y (FailureT e c) = FailureT e (Fix x (Failure e y) c)
instance (ArrowChoice c, ArrowFix x (Failure e y) c) => ArrowFix x y (FailureT e c) where
fix = liftFix' runFailureT FailureT
instance (ArrowExcept e c, ArrowChoice c) => ArrowExcept e (FailureT e' c) where
type Join (FailureT e' c) x y = Exc.Join c x (Error e' y)
type Join (FailureT e' c) x y = Exc.Join c x (Failure e' y)
throw = lift throw
catch (FailureT f) (FailureT g) = FailureT (catch f g)
finally (FailureT f) (FailureT g) = FailureT (finally f g)
instance (Identifiable e, ArrowChoice c, ArrowDeduplicate x (Error e y) c) => ArrowDeduplicate x y (FailureT e c) where
instance (Identifiable e, ArrowChoice c, ArrowDeduplicate x (Failure e y) c) => ArrowDeduplicate x y (FailureT e c) where
dedup (FailureT f) = FailureT (dedup f)
instance (ArrowChoice c, ArrowConst x c) => ArrowConst x (FailureT e c) where
askConst = lift askConst
deriving instance PreOrd (c x (Error e y)) => PreOrd (FailureT e c x y)
deriving instance LowerBounded (c x (Error e y)) => LowerBounded (FailureT e c x y)
deriving instance Complete (c x (Error e y)) => Complete (FailureT e c x y)
deriving instance CoComplete (c x (Error e y)) => CoComplete (FailureT e c x y)
deriving instance UpperBounded (c x (Error e y)) => UpperBounded (FailureT e c x y)
instance (ArrowJoin c, ArrowChoice c) => ArrowJoin (FailureT e c) where
joinWith lub' (FailureT f) (FailureT g) = FailureT $ joinWith (\r1 r2 -> case (r1, r2) of
(Success y1, Success y2) -> Success (y1 `lub'` y2)
(Success y, Fail _) -> Success y
(Fail _, Success y) -> Success y
(Fail e1, Fail _) -> Fail e1
) f g
deriving instance PreOrd (c x (Failure e y)) => PreOrd (FailureT e c x y)
deriving instance LowerBounded (c x (Failure e y)) => LowerBounded (FailureT e c x y)
deriving instance Complete (c x (Failure e y)) => Complete (FailureT e c x y)
deriving instance CoComplete (c x (Failure e y)) => CoComplete (FailureT e c x y)
deriving instance UpperBounded (c x (Failure e y)) => UpperBounded (FailureT e c x y)
......@@ -54,7 +54,7 @@ instance (ArrowChoice c, ArrowState s c) => ArrowState s (ExceptT e c) where
get = lift get
put = lift put
instance (ArrowChoice c, ArrowFail e c) => ArrowFail e (ExceptT e c) where
instance (ArrowChoice c, ArrowFail f c) => ArrowFail f (ExceptT e c) where
fail = lift fail
instance (ArrowChoice c, ArrowReader r c) => ArrowReader r (ExceptT e c) where
......
......@@ -22,12 +22,12 @@ import Control.Arrow.State
import Control.Arrow.Except as Exc
import Control.Category
import Data.Concrete.Error
import Data.Concrete.Failure
import Data.Monoidal
import Data.Identifiable
-- | Arrow transformer that adds failure to the result of a computation
newtype FailureT e c x y = FailureT { runFailureT :: c x (Error e y) }
newtype FailureT e c x y = FailureT { runFailureT :: c x (Failure e y) }
instance ArrowLift (FailureT e) where
lift f = FailureT (f >>> arr Success)
......@@ -59,31 +59,31 @@ instance (ArrowChoice c, ArrowReader r c) => ArrowReader r (FailureT e c) where
local (FailureT f) = FailureT (local f)
instance (ArrowChoice c, ArrowEnv x y env c) => ArrowEnv x y env (FailureT e c) where
type Join (FailureT e c) x y = Env.Join c x (Error e y)
type Join (FailureT e c) x y = Env.Join c x (Failure e y)
lookup (FailureT f) (FailureT g) = FailureT $ lookup f g
getEnv = lift getEnv
extendEnv = lift extendEnv
localEnv (FailureT f) = FailureT (localEnv f)
instance (ArrowChoice c, ArrowStore var val c) => ArrowStore var val (FailureT e c) where
type Join (FailureT e c) x y = Store.Join c x (Error e y)
type Join (FailureT e c) x y = Store.Join c x (Failure e y)
read (FailureT f) (FailureT g) = FailureT $ read f g
write = lift write
type instance Fix x y (FailureT e c) = FailureT e (Fix x (Error e y) c)
instance (ArrowChoice c, ArrowFix x (Error e y) c) => ArrowFix x y (FailureT e c) where
type instance Fix x y (FailureT e c) = FailureT e (Fix x (Failure e y) c)
instance (ArrowChoice c, ArrowFix x (Failure e y) c) => ArrowFix x y (FailureT e c) where
fix = liftFix' runFailureT FailureT
instance ArrowChoice c => ArrowFail e (FailureT e c) where
fail = FailureT $ arr Fail
instance (ArrowChoice c, ArrowExcept e c) => ArrowExcept e (FailureT e' c) where
type Join (FailureT e' c) x y = Exc.Join c x (Error e' y)
type Join (FailureT e' c) x y = Exc.Join c x (Failure e' y)
throw = lift throw
catch (FailureT f) (FailureT g) = FailureT $ catch f g
finally (FailureT f) (FailureT g) = FailureT $ finally f g
instance (Identifiable e, ArrowChoice c, ArrowDeduplicate x (Error e y) c) => ArrowDeduplicate x y (FailureT e c) where
instance (Identifiable e, ArrowChoice c, ArrowDeduplicate x (Failure e y) c) => ArrowDeduplicate x y (FailureT e c) where
dedup (FailureT f) = FailureT (dedup f)
instance (ArrowChoice c, ArrowConst r c) => ArrowConst r (FailureT e c) where
......
......@@ -7,7 +7,9 @@ module Data.Abstract.Failure where
import Control.Monad
import Control.Monad.Except
import Data.Abstract.FreeCompletion
import Data.Abstract.Widening
import Data.Bifunctor
import Data.Hashable
import Data.Order
......@@ -15,18 +17,18 @@ import Data.Monoidal
-- | Failure is an Either-like type with the special ordering Failure ⊑ Success.
-- Left and Right of the regular Either type, on the other hand are incomparable.
data Error e a = Fail e | Success a
data Failure e a = Fail e | Success a
deriving (Eq, Functor)
instance (Show e,Show a) => Show (Error e a) where
show (Fail e) = "Error " ++ show e
instance (Show e,Show a) => Show (Failure e a) where
show (Fail e) = "Failure " ++ show e
show (Success a) = show a
instance (Hashable e, Hashable a) => Hashable (Error e a) where
instance (Hashable e, Hashable a) => Hashable (Failure e a) where
hashWithSalt s (Fail e) = s `hashWithSalt` (0::Int) `hashWithSalt` e
hashWithSalt s (Success a) = s `hashWithSalt` (1::Int) `hashWithSalt` a
instance PreOrd a => PreOrd (Error e a) where
instance PreOrd a => PreOrd (Failure e a) where
Fail _ Success _ = True
Fail _ Fail _ = True
Success x Success y = x y
......@@ -36,111 +38,123 @@ instance PreOrd a => PreOrd (Error e a) where
Success x Success y = x y
_ _ = False
instance Complete a => Complete (Error e a) where
instance Complete a => Complete (Failure e a) where
Fail _ b = b
a Fail _ = a
Success x Success y = Success (x y)
instance UpperBounded a => UpperBounded (Error e a) where
instance UpperBounded a => UpperBounded (Failure e a) where
top = Success top
widening :: Widening a -> Widening (Error e a)
widening :: Widening a -> Widening (Failure e a)
widening _ (Fail _) b = b
widening _ a (Fail _) = a
widening w (Success x) (Success y) = Success (x `w` y)
instance MonadError e (Error e) where
instance (PreOrd e, PreOrd a, Complete (FreeCompletion a)) => Complete (FreeCompletion (Failure e a)) where
Lower m1 Lower m2 = case (bimap Lower Lower m1 bimap Lower Lower m2) of
Fail (Lower e) -> Lower (Fail e)
Success (Lower a) -> Lower (Success a)
_ -> Top
_ _ = Top
instance Bifunctor Failure where
bimap f g x = case x of
Fail e -> Fail (f e)
Success a -> Success (g a)
instance MonadError e (Failure e) where
throwError = Fail
catchError (Fail e) f = f e
catchError (Success a) _ = Success a
instance Applicative (Error e) where
instance Applicative (Failure e) where
pure = return
(<*>) = ap
instance Monad (Error e) where
instance Monad (Failure e) where
return = Success
Fail e >>= _ = Fail e
Success a >>= k = k a
fromError :: a -> Error e a -> a
fromError _ (Success a) = a
fromError a (Fail _) = a
fromFailure :: a -> Failure e a -> a
fromFailure _ (Success a) = a
fromFailure a (Fail _) = a
fromEither :: Either e a -> Error e a
fromEither :: Either e a -> Failure e a
fromEither (Left e) = Fail e
fromEither (Right a) = Success a
toEither :: Error e a -> Either e a
toEither :: Failure e a -> Either e a
toEither (Fail e) = Left e
toEither (Success a) = Right a
fromMaybe :: Maybe a -> Error () a
fromMaybe :: Maybe a -> Failure () a
fromMaybe Nothing = Fail ()
fromMaybe (Just a) = Success a
toMaybe :: Error e a -> Maybe a
toMaybe :: Failure e a -> Maybe a
toMaybe (Fail _) = Nothing
toMaybe (Success a) = Just a
instance Monoidal Error where
instance Monoidal Failure where
mmap f _ (Fail x) = Fail (f x)
mmap _ g (Success y) = Success (g y)
assoc = Iso assocTo assocFrom
where
assocTo :: Error a (Error b c) -> Error (Error a b) c
assocTo :: Failure a (Failure b c) -> Failure (Failure a b) c
assocTo (Fail a) = Fail (Fail a)
assocTo (Success (Fail b)) = Fail (Success b)
assocTo (Success (Success c)) = Success c
assocFrom :: Error (Error a b) c -> Error a (Error b c)
assocFrom :: Failure (Failure a b) c -> Failure a (Failure b c)
assocFrom (Fail (Fail a)) = Fail a
assocFrom (Fail (Success b)) = Success (Fail b)
assocFrom (Success c) = Success (Success c)
instance Symmetric Error where
instance Symmetric Failure where
commute (Fail a) = Success a
commute (Success a) = Fail a
instance Strong Error where
instance Strong Failure where
strength (Success a) = pure $ Success a
strength (Fail a) = Fail <$> a
instance Distributive (,) Error where
instance Distributive (,) Failure where
distribute = Iso distTo distFrom
where
distTo :: (a,Error b c) -> Error (a,b) (a,c)
distTo :: (a,Failure b c) -> Failure (a,b) (a,c)
distTo (a,Fail b) = Fail (a,b)
distTo (a,Success c) = Success (a,c)
distFrom :: Error (a,b) (a,c) -> (a,Error b c)
distFrom :: Failure (a,b) (a,c) -> (a,Failure b c)
distFrom (Fail (a,b)) = (a,Fail b)
distFrom (Success (a,c)) = (a,Success c)
instance Distributive Either Error where
instance Distributive Either Failure where
distribute = Iso distTo distFrom
where
distTo :: Either a (Error b c) -> Error (Either a b) (Either a c)
distTo :: Either a (Failure b c) -> Failure (Either a b) (Either a c)
distTo (Left a) = Fail (Left a)
distTo (Right (Fail b)) = Fail (Right b)
distTo (Right (Success c)) = Success (Right c)
distFrom :: Error (Either a b) (Either a c) -> Either a (Error b c)
distFrom :: Failure (Either a b) (Either a c) -> Either a (Failure b c)
distFrom (Fail (Left a)) = Left a
distFrom (Fail (Right b)) = Right (Fail b)
distFrom (Success (Left a)) = Left a
distFrom (Success (Right c)) = Right (Success c)
instance Distributive Error Either where
instance Distributive Failure Either where
distribute = Iso distTo distFrom
where
distTo :: Error a (Either b c) -> Either (Error a b) (Error a c)
distTo :: Failure a (Either b c) -> Either (Failure a b) (Failure a c)
distTo (Fail a) = Right (Fail a)
distTo (Success (Left b)) = Left (Success b)
distTo (Success (Right c)) = Right (Success c)
distFrom :: Either (Error a b) (Error a c) -> Error a (Either b c)
distFrom :: Either (Failure a b) (Failure a c) -> Failure a (Either b c)
distFrom (Left (Fail a)) = Fail a
distFrom (Left (Success b)) = Success (Left b)
distFrom (Right (Fail a)) = Fail a
......
......@@ -41,7 +41,7 @@ instance (Num n, Ord n) => Num (Interval n) where
signum = withBounds1 signum
fromInteger = constant . fromInteger
instance (Integral n, Num n, Ord n) => Numeric (Interval (InfiniteNumber n)) (Error String) where
instance (Integral n, Num n, Ord n) => Numeric (Interval (InfiniteNumber n)) (Failure String) where
Interval i1 i2 / Interval j1 j2
| j1 P.== 0 && j2 P.== 0 = Fail "divided by 0 error"
| j1 P.== 0 && 0 P.< j2 = Fail "divided by 0 error" Interval i1 i2 / Interval (j1+1) j2
......
......@@ -56,7 +56,7 @@ instance Num Sign where
| n < 0 = Negative
| otherwise = Positive
instance Numeric Sign (Error String) where
instance Numeric Sign (Failure String) where
Negative / Negative = Success Positive
Positive / Negative = Success Negative
Negative / Positive = Success Negative
......
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Concrete.Failure where
import Data.Hashable
import Data.Monoidal
import Control.Monad
data Failure e x = Fail e | Success x
deriving (Eq, Functor)
instance (Show e,Show a) => Show (Failure e a) where
show (Fail e) = "Failure " ++ show e
show (Success a) = show a
instance (Hashable e, Hashable a) => Hashable (Failure e a) where
hashWithSalt s (Fail e) = s `hashWithSalt` (1 :: Int) `hashWithSalt` e
hashWithSalt s (Success a) = s `hashWithSalt` (2 :: Int) `hashWithSalt` a
instance Applicative (Failure e) where
pure = return
(<*>) = ap
instance Monad (Failure e) where
return = Success
Fail e >>= _ = Fail e
Success a >>= k = k a
toEither :: Failure e x -> Either e x
toEither (Fail e) = Left e
toEither (Success e) = Right e
instance Monoidal Failure where
mmap f _ (Fail x) = Fail (f x)
mmap _ g (Success y) = Success (g y)
assoc = Iso assocTo assocFrom
where
assocTo :: Failure a (Failure b c) -> Failure (Failure a b) c
assocTo (Fail a) = Fail (Fail a)
assocTo (Success (Fail b)) = Fail (Success b)
assocTo (Success (Success c)) = Success c
assocFrom :: Failure (Failure a b) c -> Failure a (Failure b c)
assocFrom (Fail (Fail a)) = Fail a
assocFrom (Fail (Success b)) = Success (Fail b)
assocFrom (Success c) = Success (Success c)
instance Symmetric Failure where
commute (Fail a) = Success a
commute (Success a) = Fail a
instance Distributive (,) Failure where
distribute = Iso distTo distFrom
where
distTo :: (a,Failure b c) -> Failure (a,b) (a,c)
distTo (a,Fail b) = Fail (a,b)
distTo (a,Success c) = Success (a,c)
distFrom :: Failure (a,b) (a,c) -> (a,Failure b c)
distFrom (Fail (a,b)) = (a,Fail b)
distFrom (Success (a,c)) = (a,Success c)
instance Distributive Either Failure where
distribute = Iso distTo distFrom
where
distTo :: Either a (Failure b c) -> Failure (Either a b) (Either a c)
distTo (Left a) = Fail (Left a)
distTo (Right (Fail b)) = Fail (Right b)
distTo (Right (Success c)) = Success (Right c)
distFrom :: Failure (Either a b) (Either a c) -> Either a (Failure b c)
distFrom (Fail (Left a)) = Left a
distFrom (Fail (Right b)) = Right (Fail b)
distFrom (Success (Left a)) = Left a
distFrom (Success (Right c)) = Right (Success c)
instance Distributive Failure Either where
distribute = Iso distTo distFrom
where
distTo :: Failure a (Either b c) -> Either (Failure a b) (Failure a c)
distTo (Fail a) = Right (Fail a)
distTo (Success (Left b)) = Left (Success b)
distTo (Success (Right c)) = Right (Success c)
distFrom :: Either (Failure a b) (Failure a c) -> Failure a (Either b c)
distFrom (Left (Fail a)) = Fail a
distFrom (Left (Success b)) = Success (Left b)
distFrom (Right (Fail a)) = Fail a
distFrom (Right (Success c)) = Success (Right c)
......@@ -36,6 +36,7 @@ library
Data.Concrete.Boolean,
Data.Concrete.Error,
Data.Concrete.Failure,
Data.Concrete.Powerset,
Data.Abstract.Either,
......
......@@ -22,7 +22,7 @@ import Control.Arrow.Transformer.Concrete.Failure
import Control.Arrow.Transformer.Concrete.Fixpoint
import Control.Monad.State hiding (fail)
import Data.Concrete.Error
import Data.Concrete.Failure
import Data.HashMap.Lazy (HashMap)
import Data.Hashable
import Data.Text (Text)
......@@ -39,7 +39,7 @@ data Val = NumVal Int | ClosureVal Closure deriving (Eq,Generic)
-- | The concrete interpreter function for PCF. The function is
-- implemented by instantiating the shared semantics with the concrete
-- interpreter arrow `Interp`.
evalConcrete :: [(Text,Val)] -> State Label Expr -> Error String Val
evalConcrete :: [(Text,Val)] -> State Label Expr -> Failure String Val
evalConcrete env e =
runFix
(runFailureT
......
......@@ -41,7 +41,7 @@ import Data.Text (Text)
import Data.Abstract.Map(Map)
import qualified Data.Abstract.Map as M
import qualified Data.Abstract.FiniteMap as F
import Data.Abstract.Failure (Error)
import Data.Abstract.Failure (Failure)
import qualified Data.Abstract.Failure as E
import Data.Abstract.InfiniteNumbers
import Data.Abstract.Interval (Interval)
......@@ -71,7 +71,7 @@ type Addr = (Text,CallString Label)
-- | Run the abstract interpreter for the k-CFA / Interval analysis. The arguments are the
-- maximum interval bound, the depth `k` of the longest call string,
-- an environment, and the input of the computation.
evalInterval :: (?bound :: IV) => Int -> [(Text,Val)] -> State Label Expr -> Terminating (Error String Val)
evalInterval :: (?bound :: IV) => Int -> [(Text,Val)] -> State Label Expr -> Terminating (Failure String Val)
evalInterval k env e = -- runInterp eval ?bound k env (generate e)
runFixT' stackWiden (E.widening widenVal)
(runFailureT
......
......@@ -9,6 +9,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
module ConcreteSemantics where
......@@ -28,6 +29,7 @@ import Control.Arrow.Fix
import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Transformer.Concrete.Except
import Control.Arrow.Transformer.Concrete.Failure
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Control.Category
......@@ -35,6 +37,7 @@ import Control.Monad (join)
import Control.Monad.Reader (replicateM)
import Data.Concrete.Error
import Data.Concrete.Failure (Failure)
import Data.Constructor
import Data.Foldable (foldr')
import Data.HashMap.Lazy (HashMap)
......@@ -57,25 +60,24 @@ newtype TermEnv = TermEnv (HashMap TermVar Term) deriving (Show,Eq,Hashable)
-- | Concrete interpreter arrow give access to the strategy
-- environment, term environment, and handles anonymous exceptions.
newtype Interp a b = Interp (ReaderT StratEnv (StateT TermEnv (ExceptT () (->))) a b)
newtype Interp a b = Interp (ReaderT StratEnv (StateT TermEnv (ExceptT () (FailureT String (->)))) a b)
deriving (Category,Arrow,ArrowChoice,ArrowApply)
-- | Executes a concrete interpreter computation.
runInterp :: Interp a b -> StratEnv -> TermEnv -> a -> Error () (TermEnv,b)
runInterp (Interp f) senv tenv t = runExceptT (runStateT (runReaderT f)) (tenv, (senv, t))
runInterp :: Interp a b -> StratEnv -> TermEnv -> a -> Failure String (Error () (TermEnv,b))
runInterp (Interp f) senv tenv t = runFailureT (runExceptT (runStateT (runReaderT f))) (tenv, (senv, t))
-- | Concrete interpreter function.
eval :: Strat -> StratEnv -> TermEnv -> Term -> Error () (TermEnv,Term)
eval :: Strat -> StratEnv -> TermEnv -> Term -> Failure String (Error () (TermEnv,Term))
eval s = runInterp (eval' s)
-- Instances -----------------------------------------------------------------------------------------
deriving instance ArrowState TermEnv Interp
deriving instance ArrowReader StratEnv Interp
deriving instance ArrowExcept () Interp
deriving instance ArrowFix (Strat,Term) Term Interp
deriving instance ArrowDeduplicate Term Term Interp
instance ArrowFail () Interp where
fail = Interp fail
deriving instance ArrowFail String Interp
instance HasStratEnv Interp where
readStratEnv = Interp (const () ^>> ask)
......@@ -84,10 +86,10 @@ instance HasStratEnv Interp where
instance IsTermEnv TermEnv Term Interp where
getTermEnv = get
putTermEnv = put
lookupTermVar f g = proc (v,TermEnv env) ->
lookupTermVar f g = proc (v,TermEnv env,exc) ->
case M.lookup v env of
Just t -> f -< t
Nothing -> g -< ()
Nothing -> g -< exc
insertTerm = arr $ \(v,t,TermEnv env) ->
TermEnv (M.insert v t env)
deleteTermVars = arr $ \(vars,TermEnv env) ->
......@@ -100,19 +102,19 @@ instance IsTerm Term Interp where
Cons c' ts' | c == c' && eqLength ts ts' -> do
ts'' <- matchSubterms -< (ts,ts')
returnA -< Cons c ts''
_ -> fail -< ()
_ -> throw -< ()
matchTermAgainstString = proc (s,t) -> case t of
StringLiteral s'
| s == s' -> returnA -< t
| otherwise -> fail -< ()
_ -> fail -< ()
| otherwise -> throw -< ()
_ -> throw -< ()
matchTermAgainstNumber = proc (n,t) -> case t of
NumberLiteral n'
| n == n' -> returnA -< t
| otherwise -> fail -< ()
_ -> fail -< ()
| otherwise -> throw -< ()
_ -> throw -< ()
matchTermAgainstExplode matchCons matchSubterms = proc t -> case t of
Cons (Constructor c) ts -> do
......@@ -136,11 +138,11 @@ instance IsTerm Term Interp where
| s == s' -> success -< t1
(NumberLiteral n, NumberLiteral n')
| n == n' -> success -< t1
(_,_) -> fail -< ()
(_,_) -> throw -< ()
convertFromList = proc (c,ts) -> case (c,go ts) of
(StringLiteral c', Just ts') -> returnA -< Cons (Constructor c') ts'
_ -> fail -< ()
_ -> throw -< ()
where
go t = case t of
Cons "Cons" [x,tl] -> (x:) <$> go tl
......@@ -202,7 +204,7 @@ instance Arbitrary Term where
similar :: Gen (Term,Term)
similar = do
[t1,t2] <- similarTerms 2 5 2 7
~[t1,t2] <- similarTerms 2 5 2 7
return (t1,t2)
similarTerms :: Int -> Int -> Int -> Int -> Gen [Term]
......
......@@ -30,14 +30,14 @@ import Data.Text(Text)
import Text.Printf
-- | Shared interpreter for Stratego
eval' :: (ArrowChoice c, ArrowFail () c, ArrowExcept () c,
eval' :: (ArrowChoice c, ArrowFail String c, ArrowExcept () c,
ArrowApply c, ArrowFix (Strat,t) t c, ArrowDeduplicate t t c, Eq t, Hashable t,
HasStratEnv c, IsTerm t c, IsTermEnv env t c,
Exc.Join c (t,(t,())) t, Exc.Join c ((t,[t]),((t,[t]),())) (t,[t]))
=> (Strat -> c t t)
eval' = fixA' $ \ev s0 -> dedup $ case s0 of
Id -> id
S.Fail -> fail'
S.Fail -> proc _ -> throw -< ()
Seq s1 s2 -> sequence (ev s1) (ev s2)
GuardedChoice s1 s2 s3 -> guardedChoice (ev s1) (ev s2) (ev s3)
One s -> mapSubterms (one (ev s))
......@@ -61,16 +61,16 @@ sequence :: Category c => c x y -> c y z -> c x z
sequence f g = f >>> g
-- | Apply a strategy non-determenistically to one of the subterms.
one :: (ArrowChoice c, ArrowFail () c, ArrowExcept () c, Exc.Join c ((t,[t]),((t,[t]),())) (t,[t])) => c t t -> c [t] [t]
one :: (ArrowChoice c, ArrowExcept () c, Exc.Join c ((t,[t]),((t,[t]),())) (t,[t])) => c t t -> c [t] [t]
one f = proc l -> case l of
(t:ts) -> do
(t',ts') <- first f <+> second (one f) -< (t,ts)
returnA -< (t':ts')
[] -> fail -< ()
[] -> throw -< ()
-- | Apply a strategy to as many subterms as possible (as long as the