Commit f973c188 authored by Jente Hidskes's avatar Jente Hidskes

Update Stratego to use Control.Arrow.Fail

parent 2e69fb34
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
module Control.Arrow.Utils where
import Control.Arrow
import Control.Arrow.Fail
mapA :: ArrowChoice c => c x y -> c [x] [y]
mapA f = proc l -> case l of
......@@ -54,3 +56,6 @@ eject :: Either (r,a) (r,b) -> (r,Either a b)
eject e = case e of
Left (r,a) -> (r,Left a)
Right (r,b) -> (r,Right b)
failA' :: ArrowFail () c => c a b
failA' = arr (const ()) >>> failA
......@@ -8,10 +8,11 @@ module Data.AbstractPowerset where
import Prelude hiding ((.))
import Control.Applicative hiding (empty)
import Control.Category
import Control.Applicative
import Control.Monad
import Control.Monad.Deduplicate
import Control.Monad.Except
import Data.Sequence (Seq)
import Data.Hashable
......@@ -21,7 +22,7 @@ import Data.Foldable (foldl',toList)
import Data.List (intercalate)
import Data.Order
import GHC.Generics (Generic)
import GHC.Generics (Generic)
newtype Pow a = Pow (Seq a) deriving (Functor, Applicative, Monad, Alternative, MonadPlus, Monoid, Foldable, Traversable, Generic)
......@@ -40,6 +41,11 @@ instance Show a => Show (Pow a) where
instance (Eq a, Hashable a) => Hashable (Pow a) where
hashWithSalt salt x = hashWithSalt salt (toHashSet x)
instance MonadError () Pow where
throwError _ = empty
catchError a f | null a = f ()
| otherwise = a
empty :: Pow a
empty = mempty
......
......@@ -11,7 +11,7 @@
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
module ConcreteSemantics where
import Prelude hiding (id,(.),fail,all,curry,uncurry)
import Prelude hiding (id,(.),all,curry,uncurry)
-- import InterpreterArrow
import SharedSemantics
......@@ -21,14 +21,15 @@ import Syntax hiding (Fail,TermPattern(..))
import Utils
import Control.Arrow
import Control.Arrow.Fix
import Control.Arrow.Try
import Control.Arrow.Apply
import Control.Arrow.Debug
import Control.Arrow.Deduplicate
import Control.Monad.Reader hiding (fail)
import Control.Monad.State hiding (fail)
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Try
import Control.Category
import Control.Monad.Reader
import Control.Monad.State
import Data.Constructor
import Data.Result
......@@ -75,6 +76,9 @@ liftK f = Interp (Kleisli f)
instance ArrowFix Interp Term where
fixA f = f (fixA f)
instance ArrowFail () Interp where
failA = Interp failA
instance ArrowDebug Interp where
debug s f = proc a -> do
b <- f -< a
......
......@@ -3,16 +3,15 @@
{-# LANGUAGE UndecidableInstances #-}
module Control.Monad.Result where
import Prelude hiding (fail)
import Control.Applicative
import Control.Monad hiding (fail)
import Control.Monad.Trans
import Control.Monad.State hiding (fail)
import Control.Monad.Reader hiding (fail)
import Control.Monad
import Control.Monad.Deduplicate
import Control.Monad.Try
import Control.Monad.Except
import Control.Monad.Join (MonadJoin)
import qualified Control.Monad.Join as J
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Try
import Data.Result
import Data.Order
......@@ -48,7 +47,6 @@ instance MonadReader r m => MonadReader r (ResultT m) where
local = mapResultT . local
instance Monad m => MonadTry (ResultT m) where
fail = ResultT (return fail)
try (ResultT f) g (ResultT h) = ResultT $ do
r <- f
case r of
......@@ -75,3 +73,10 @@ instance PreOrd (m (Result a)) => PreOrd (ResultT m a) where
instance Complete (m (Result a)) => Complete (ResultT m a) where
(ResultT m1) (ResultT m2) = ResultT (m1 m2)
instance MonadError () m => MonadError () (ResultT m) where
throwError _ = ResultT $ return Fail
catchError m h = ResultT $ do
r <- runResultT m
case r of
Fail -> runResultT (h ())
Success a -> return (Success a)
......@@ -3,13 +3,12 @@
{-# LANGUAGE Arrows #-}
module Data.Result where
import Prelude hiding (map)
import Control.Monad
import Control.Monad.Try
import Control.Monad.Deduplicate
import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.Deduplicate
import Control.Monad.Except
import Control.Monad.Try
import Data.Hashable
import Data.Semigroup
......@@ -57,7 +56,6 @@ instance MonadPlus Result where
mplus Fail r = r
instance MonadTry Result where
fail = Fail
try Fail _ m2 = m2
try (Success a) k _ = k a
......@@ -86,3 +84,8 @@ instance PreOrd a => PreOrd (Result a) where
instance Galois x y => Galois (Result x) (Result y) where
alpha = fmap alpha
gamma = fmap gamma
instance MonadError () Result where
throwError _ = Fail
catchError Fail f = f ()
catchError a _ = a
......@@ -14,9 +14,11 @@ import qualified Syntax as S
import Utils
import Control.Arrow
import Control.Arrow.Try
import Control.Arrow.Fix
import Control.Arrow.Deduplicate
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Try
import Control.Arrow.Utils hiding (mapA,zipWithA)
import Control.Category
import qualified Data.HashMap.Lazy as M
......@@ -28,12 +30,12 @@ import Text.Printf
-- Shared interpreter for Stratego
eval' :: (ArrowChoice c, ArrowTry c, ArrowPlus c, ArrowApply c, ArrowFix c t,
ArrowDeduplicate c, Eq t, Hashable t,
ArrowFail () c, ArrowDeduplicate c, Eq t, Hashable t,
HasStratEnv c, IsTerm t c, IsTermEnv env t c)
=> (Strat -> c t t)
eval' = fixA $ \ev s0 -> dedupA $ case s0 of
Id -> id
S.Fail -> failA
S.Fail -> failA'
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))
......@@ -51,14 +53,14 @@ guardedChoice = tryA
sequence :: Category c => c x y -> c y z -> c x z
sequence f g = f >>> g
one :: (ArrowChoice c, ArrowTry c, ArrowPlus c) => c t t -> c [t] [t]
one :: (ArrowChoice c, ArrowFail () c, ArrowTry c, ArrowPlus c) => 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')
[] -> failA -< ()
some :: (ArrowChoice c, ArrowTry c) => c t t -> c [t] [t]
some :: (ArrowChoice c, ArrowFail () c, ArrowTry c) => c t t -> c [t] [t]
some f = go
where
go = proc l -> case l of
......@@ -91,7 +93,7 @@ let_ ss body interp = proc a -> do
senv <- readStratEnv -< ()
localStratEnv (M.union (M.fromList ss') senv) (interp body) -<< a
call :: (ArrowChoice c, ArrowTry c, ArrowPlus c, ArrowApply c,
call :: (ArrowChoice c, ArrowFail () c, ArrowTry c, ArrowPlus c, ArrowApply c,
IsTermEnv env t c, HasStratEnv c)
=> StratVar
-> [Strat]
......@@ -148,7 +150,7 @@ match = proc (p,t) -> case p of
S.NumberLiteral n ->
matchTermAgainstNumber -< (n,t)
build :: (ArrowChoice c, ArrowTry c, IsTerm t c, IsTermEnv env t c)
build :: (ArrowChoice c, ArrowFail () c, ArrowTry c, IsTerm t c, IsTermEnv env t c)
=> c TermPattern t
build = proc p -> case p of
S.As _ _ -> error "As-pattern in build is disallowed" -< ()
......
......@@ -8,19 +8,21 @@
{-# OPTIONS_GHC -Wno-partial-type-signatures -fno-warn-orphans #-}
module WildcardSemantics where
import Prelude hiding (id,fail,concat,sequence,(.),uncurry)
import Prelude hiding (id,concat,sequence,(.),uncurry)
import SharedSemantics
import qualified ConcreteSemantics as C
import Utils
import Syntax hiding (Fail,TermPattern(..))
import SharedSemantics
import Soundness
import Syntax hiding (Fail,TermPattern(..))
import Utils
import Control.Arrow
import Control.Arrow.Apply
import Control.Arrow.Try
import Control.Arrow.Fix
import Control.Arrow.Fail
import Control.Arrow.Deduplicate
import Control.Arrow.Utils (failA')
import Control.Category
import Control.DeepSeq
import Control.Monad.Reader
......@@ -70,6 +72,9 @@ emptyEnv :: TermEnv
emptyEnv = TermEnv M.empty
-- Instances -----------------------------------------------------------------------------------------
instance ArrowFail () Interp where
failA = Interp failA
instance HasStratEnv Interp where
readStratEnv = liftK (const (fst <$> ask))
localStratEnv senv (Interp (Kleisli f)) = liftK (local (first (const senv)) . f)
......@@ -97,7 +102,7 @@ instance IsTerm Term Interp where
returnA -< Cons c ts''
Wildcard -> do
ts'' <- matchSubterms -< (ts,[ Wildcard | _ <- [1..(length ts)] ])
returnA failA -< Cons c ts''
returnA failA' -< Cons c ts''
_ -> failA -< ()
matchTermAgainstString = proc (s,t) -> case t of
......@@ -105,16 +110,16 @@ instance IsTerm Term Interp where
| s == s' -> returnA -< t
| otherwise -> failA -< ()
Wildcard ->
returnA failA -< StringLiteral s
_ -> failA -< ()
returnA failA' -< StringLiteral s
_ -> failA' -< ()
matchTermAgainstNumber = proc (n,t) -> case t of
NumberLiteral n'
| n == n' -> returnA -< t
| otherwise -> failA -< ()
Wildcard ->
success failA -< NumberLiteral n
_ -> failA -< ()
success failA' -< NumberLiteral n
_ -> failA' -< ()
matchTermAgainstExplode matchCons matchSubterms = proc t -> case t of
Cons (Constructor c) ts -> do
......@@ -151,15 +156,15 @@ instance IsTerm Term Interp where
(NumberLiteral n, NumberLiteral n')
| n == n' -> success -< t1
| otherwise -> failA -< ()
(Wildcard, t) -> failA success -< t
(t, Wildcard) -> failA success -< t
(_,_) -> failA -< ()
(Wildcard, t) -> failA' success -< t
(t, Wildcard) -> failA' success -< t
(_,_) -> failA' -< ()
convertFromList = proc (c,ts) -> case (c,go ts) of
(StringLiteral c', Just ts'') -> returnA -< Cons (Constructor c') ts''
(Wildcard, Just _) -> failA success -< Wildcard
(_, Nothing) -> failA success -< Wildcard
_ -> failA -< ()
(Wildcard, Just _) -> failA' success -< Wildcard
(_, Nothing) -> failA' success -< Wildcard
_ -> failA' -< ()
where
go t = case t of
Cons "Cons" [x,tl] -> (x:) <$> go tl
......@@ -174,7 +179,7 @@ instance IsTerm Term Interp where
returnA -< Cons c ts'
StringLiteral _ -> returnA -< t
NumberLiteral _ -> returnA -< t
Wildcard -> failA success -< Wildcard
Wildcard -> failA' success -< Wildcard
cons = arr (uncurry Cons)
......@@ -182,7 +187,7 @@ instance IsTerm Term Interp where
stringLiteral = arr StringLiteral
instance UpperBounded (Interp () Term) where
top = proc () -> success failA -< Wildcard
top = proc () -> success failA' -< Wildcard
instance ArrowFix Interp Term where
fixA f z = proc x -> do
......
......@@ -49,7 +49,8 @@ library
unordered-containers,
mtl,
pretty,
text
text,
transformers
hs-source-dirs: src
default-language: Haskell2010
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment