{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BlockArguments #-}
module Language.Change
(
PSet(..), member
, Pattern(..), Env(..)
, testPatterns, testEnv
, Change(..)
, applyChange, applyChanges, traceChanges, replace
) where
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Set (Set)
import Data.Map (Map)
import Data.List (find, foldl', scanl')
data PSet a = PSet (Set a) Bool
deriving (Int -> PSet a -> ShowS
forall a. Show a => Int -> PSet a -> ShowS
forall a. Show a => [PSet a] -> ShowS
forall a. Show a => PSet a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PSet a] -> ShowS
$cshowList :: forall a. Show a => [PSet a] -> ShowS
show :: PSet a -> String
$cshow :: forall a. Show a => PSet a -> String
showsPrec :: Int -> PSet a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> PSet a -> ShowS
Show)
member :: Ord a => a -> PSet a -> Bool
member :: forall a. Ord a => a -> PSet a -> Bool
member a
x (PSet Set a
set Bool
b) = forall a. Ord a => a -> Set a -> Bool
Set.member a
x Set a
set forall a. Eq a => a -> a -> Bool
== Bool
b
data Pattern a
= One (PSet a)
| Optional (PSet a)
| Many (PSet a)
deriving (Int -> Pattern a -> ShowS
forall a. Show a => Int -> Pattern a -> ShowS
forall a. Show a => [Pattern a] -> ShowS
forall a. Show a => Pattern a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pattern a] -> ShowS
$cshowList :: forall a. Show a => [Pattern a] -> ShowS
show :: Pattern a -> String
$cshow :: forall a. Show a => Pattern a -> String
showsPrec :: Int -> Pattern a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Pattern a -> ShowS
Show)
data Env a = Env [Pattern a] [Pattern a]
deriving (Int -> Env a -> ShowS
forall a. Show a => Int -> Env a -> ShowS
forall a. Show a => [Env a] -> ShowS
forall a. Show a => Env a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Env a] -> ShowS
$cshowList :: forall a. Show a => [Env a] -> ShowS
show :: Env a -> String
$cshow :: forall a. Show a => Env a -> String
showsPrec :: Int -> Env a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Env a -> ShowS
Show)
newtype Change a = Change (Map a [([a], Env a)])
deriving (Int -> Change a -> ShowS
forall a. Show a => Int -> Change a -> ShowS
forall a. Show a => [Change a] -> ShowS
forall a. Show a => Change a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Change a] -> ShowS
$cshowList :: forall a. Show a => [Change a] -> ShowS
show :: Change a -> String
$cshow :: forall a. Show a => Change a -> String
showsPrec :: Int -> Change a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Change a -> ShowS
Show)
testPatterns :: Ord a => [a] -> [Pattern a] -> Bool
testPatterns :: forall a. Ord a => [a] -> [Pattern a] -> Bool
testPatterns [a]
list = \case
[] -> Bool
True
One PSet a
set : [Pattern a]
ps ->
case [a]
list of
a
x:[a]
xs | forall a. Ord a => a -> PSet a -> Bool
member a
x PSet a
set -> forall a. Ord a => [a] -> [Pattern a] -> Bool
testPatterns [a]
xs [Pattern a]
ps
[a]
_ -> Bool
False
Optional PSet a
set : [Pattern a]
ps ->
forall a. Ord a => [a] -> [Pattern a] -> Bool
testPatterns [a]
list [Pattern a]
ps
Bool -> Bool -> Bool
|| forall a. Ord a => [a] -> [Pattern a] -> Bool
testPatterns [a]
list (forall a. PSet a -> Pattern a
One PSet a
set forall a. a -> [a] -> [a]
: [Pattern a]
ps)
Many PSet a
set : [Pattern a]
ps ->
forall a. Ord a => [a] -> [Pattern a] -> Bool
testPatterns [a]
list [Pattern a]
ps
Bool -> Bool -> Bool
|| forall a. Ord a => [a] -> [Pattern a] -> Bool
testPatterns [a]
list (forall a. PSet a -> Pattern a
One PSet a
set forall a. a -> [a] -> [a]
: forall a. PSet a -> Pattern a
Many PSet a
set forall a. a -> [a] -> [a]
: [Pattern a]
ps)
testEnv :: Ord a => [a] -> [a] -> Env a -> Bool
testEnv :: forall a. Ord a => [a] -> [a] -> Env a -> Bool
testEnv [a]
left [a]
right (Env [Pattern a]
psL [Pattern a]
psR) =
forall a. Ord a => [a] -> [Pattern a] -> Bool
testPatterns [a]
left [Pattern a]
psL Bool -> Bool -> Bool
&& forall a. Ord a => [a] -> [Pattern a] -> Bool
testPatterns [a]
right [Pattern a]
psR
replace :: ([a] -> a -> [a] -> [b]) -> [a] -> [b]
replace :: forall a b. ([a] -> a -> [a] -> [b]) -> [a] -> [b]
replace [a] -> a -> [a] -> [b]
f = [a] -> [a] -> [b]
replace' []
where
replace' :: [a] -> [a] -> [b]
replace' [a]
_ [] = []
replace' [a]
left (a
x:[a]
right) = [a] -> a -> [a] -> [b]
f [a]
left a
x [a]
right forall a. [a] -> [a] -> [a]
++ [a] -> [a] -> [b]
replace' (a
xforall a. a -> [a] -> [a]
:[a]
left) [a]
right
applyChange :: Ord a => Change a -> [a] -> [a]
applyChange :: forall a. Ord a => Change a -> [a] -> [a]
applyChange (Change Map a [([a], Env a)]
mapping) =
forall a b. ([a] -> a -> [a] -> [b]) -> [a] -> [b]
replace \[a]
left a
x [a]
right ->
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
x Map a [([a], Env a)]
mapping of
Maybe [([a], Env a)]
Nothing -> [a
x]
Just [([a], Env a)]
cs ->
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a. Ord a => [a] -> [a] -> Env a -> Bool
testEnv [a]
left [a]
right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [([a], Env a)]
cs of
Maybe ([a], Env a)
Nothing -> [a
x]
Just ([a]
x', Env a
_) -> [a]
x'
applyChanges :: Ord a => [Change a] -> [a] -> [a]
applyChanges :: forall a. Ord a => [Change a] -> [a] -> [a]
applyChanges [Change a]
cs [a]
x = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => Change a -> [a] -> [a]
applyChange) [a]
x [Change a]
cs
traceChanges :: Ord a => [Change a] -> [a] -> [[a]]
traceChanges :: forall a. Ord a => [Change a] -> [a] -> [[a]]
traceChanges [Change a]
cs [a]
x = forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => Change a -> [a] -> [a]
applyChange) [a]
x [Change a]
cs