{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# LANGUAGE DeriveFunctor, FlexibleContexts, LambdaCase, OverloadedStrings #-}
-- |
-- Maintainer  :  Johannes Riecken <johannes.riecken@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- This module includes combinators for rewriting Joy source code.
----------------------------------------------------------------------------
module Language.Joy.Rewrite
  ( rewrite
  , tokenize
  ) where
import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.Loops
import Data.Foldable (asum)
import Data.List
import qualified Data.Text as T
import Data.Text (Text(..))
import qualified Data.Map as M
import Data.Map (Map)
import Test.Hspec
import Text.Parsec hiding ((<|>), many)

-- | Error is a generic error type.
type Error = Text

-- A rewrite rule matches a pattern and tries to rewrite it with the
-- replacement. If there is a condition attached, the rewriting will only happen
-- if the rewrite given in the condition can happen based on known rewrite
-- rules.
data Rule = Rule
  { Rule -> [RuleExpr Text]
pat       :: [RuleExpr Text]
  , Rule -> [RuleExpr Text]
repl      :: [RuleExpr Text]
  , Rule -> Maybe Condition
condition :: Maybe Condition
  }
  deriving Int -> Rule -> ShowS
[Rule] -> ShowS
Rule -> String
(Int -> Rule -> ShowS)
-> (Rule -> String) -> ([Rule] -> ShowS) -> Show Rule
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Rule] -> ShowS
$cshowList :: [Rule] -> ShowS
show :: Rule -> String
$cshow :: Rule -> String
showsPrec :: Int -> Rule -> ShowS
$cshowsPrec :: Int -> Rule -> ShowS
Show

data Condition = Condition
  { Condition -> [RuleExpr Text]
premise    :: [RuleExpr Text]
  , Condition -> [RuleExpr Text]
conclusion :: [RuleExpr Text]
  }
  deriving Int -> Condition -> ShowS
[Condition] -> ShowS
Condition -> String
(Int -> Condition -> ShowS)
-> (Condition -> String)
-> ([Condition] -> ShowS)
-> Show Condition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Condition] -> ShowS
$cshowList :: [Condition] -> ShowS
show :: Condition -> String
$cshow :: Condition -> String
showsPrec :: Int -> Condition -> ShowS
$cshowsPrec :: Int -> Condition -> ShowS
Show

convertError :: Either ParseError a -> Either Error a
convertError :: Either ParseError a -> Either Text a
convertError (Left ParseError
x) = Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a)
-> (String -> Text) -> String -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Either Text a) -> String -> Either Text a
forall a b. (a -> b) -> a -> b
$ ParseError -> String
forall a. Show a => a -> String
show ParseError
x
convertError (Right a
x) = a -> Either Text a
forall a b. b -> Either a b
Right a
x

-- Construct a Rule by parsing a string like "a b swap => b a"
mkRule :: Text -> Either Error Rule
mkRule :: Text -> Either Text Rule
mkRule Text
xs = do
  [RuleExpr Text]
xs' <- Text -> Either Text [RuleExpr Text]
tokenizeRule Text
xs
  if RuleExpr Text
forall a. RuleExpr a
CondSep RuleExpr Text -> [RuleExpr Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [RuleExpr Text]
xs'
    then do
      ([RuleExpr Text]
v,[RuleExpr Text]
w) <- RuleExpr Text
-> [RuleExpr Text]
-> Either Text ([RuleExpr Text], [RuleExpr Text])
forall a. Eq a => a -> [a] -> Either Text ([a], [a])
cut RuleExpr Text
forall a. RuleExpr a
CondSep [RuleExpr Text]
xs'
      ([RuleExpr Text]
a,[RuleExpr Text]
b) <- RuleExpr Text
-> [RuleExpr Text]
-> Either Text ([RuleExpr Text], [RuleExpr Text])
forall a. Eq a => a -> [a] -> Either Text ([a], [a])
cut RuleExpr Text
forall a. RuleExpr a
RuleSep [RuleExpr Text]
v
      ([RuleExpr Text]
c,[RuleExpr Text]
d) <- RuleExpr Text
-> [RuleExpr Text]
-> Either Text ([RuleExpr Text], [RuleExpr Text])
forall a. Eq a => a -> [a] -> Either Text ([a], [a])
cut RuleExpr Text
forall a. RuleExpr a
RuleSep [RuleExpr Text]
w
      Rule -> Either Text Rule
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rule -> Either Text Rule) -> Rule -> Either Text Rule
forall a b. (a -> b) -> a -> b
$ [RuleExpr Text] -> [RuleExpr Text] -> Maybe Condition -> Rule
Rule [RuleExpr Text]
a [RuleExpr Text]
b (Condition -> Maybe Condition
forall a. a -> Maybe a
Just (Condition -> Maybe Condition) -> Condition -> Maybe Condition
forall a b. (a -> b) -> a -> b
$ [RuleExpr Text] -> [RuleExpr Text] -> Condition
Condition [RuleExpr Text]
c [RuleExpr Text]
d)
    else do
      ([RuleExpr Text]
a, [RuleExpr Text]
b) <- Text -> Either Text ([RuleExpr Text], [RuleExpr Text])
tokenizeFromTo Text
xs
      Rule -> Either Text Rule
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rule -> Either Text Rule) -> Rule -> Either Text Rule
forall a b. (a -> b) -> a -> b
$ [RuleExpr Text] -> [RuleExpr Text] -> Maybe Condition -> Rule
Rule [RuleExpr Text]
a [RuleExpr Text]
b Maybe Condition
forall a. Maybe a
Nothing where

  tokenizeFromTo :: Text -> Either Error ([RuleExpr Text], [RuleExpr Text])
  tokenizeFromTo :: Text -> Either Text ([RuleExpr Text], [RuleExpr Text])
tokenizeFromTo Text
xs = Text -> Either Text [RuleExpr Text]
tokenizeRule Text
xs Either Text [RuleExpr Text]
-> ([RuleExpr Text]
    -> Either Text ([RuleExpr Text], [RuleExpr Text]))
-> Either Text ([RuleExpr Text], [RuleExpr Text])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RuleExpr Text
-> [RuleExpr Text]
-> Either Text ([RuleExpr Text], [RuleExpr Text])
forall a. Eq a => a -> [a] -> Either Text ([a], [a])
cut RuleExpr Text
forall a. RuleExpr a
RuleSep

  cut :: Eq a => a -> [a] -> Either Error ([a], [a])
  cut :: a -> [a] -> Either Text ([a], [a])
cut a
_ [] = Text -> Either Text ([a], [a])
forall a b. a -> Either a b
Left Text
"tried to cut empty list"
  cut a
sep [a]
xs = ([a], [a]) -> Either Text ([a], [a])
forall a b. b -> Either a b
Right (([a], [a]) -> Either Text ([a], [a]))
-> ([a] -> ([a], [a])) -> [a] -> Either Text ([a], [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> [a]) -> ([a], [a]) -> ([a], [a])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second [a] -> [a]
forall a. [a] -> [a]
tail (([a], [a]) -> ([a], [a]))
-> ([a] -> ([a], [a])) -> [a] -> ([a], [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
sep) ([a] -> Either Text ([a], [a])) -> [a] -> Either Text ([a], [a])
forall a b. (a -> b) -> a -> b
$ [a]
xs

  tokenizeRule :: Text -> Either Error [RuleExpr Text]
  tokenizeRule :: Text -> Either Text [RuleExpr Text]
tokenizeRule = Either ParseError [RuleExpr Text] -> Either Text [RuleExpr Text]
forall a. Either ParseError a -> Either Text a
convertError (Either ParseError [RuleExpr Text] -> Either Text [RuleExpr Text])
-> (Text -> Either ParseError [RuleExpr Text])
-> Text
-> Either Text [RuleExpr Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([RuleExpr String] -> [RuleExpr Text])
-> Either ParseError [RuleExpr String]
-> Either ParseError [RuleExpr Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RuleExpr String -> RuleExpr Text)
-> [RuleExpr String] -> [RuleExpr Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> Text) -> RuleExpr String -> RuleExpr Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
T.pack)) (Either ParseError [RuleExpr String]
 -> Either ParseError [RuleExpr Text])
-> (Text -> Either ParseError [RuleExpr String])
-> Text
-> Either ParseError [RuleExpr Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec String () [RuleExpr String]
-> String -> String -> Either ParseError [RuleExpr String]
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () [RuleExpr String]
forall u. ParsecT String u Identity [RuleExpr String]
parser String
"" (String -> Either ParseError [RuleExpr String])
-> (Text -> String) -> Text -> Either ParseError [RuleExpr String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack   where
    parser :: ParsecT String u Identity [RuleExpr String]
parser =
      let metaVar :: ParsecT String u Identity (RuleExpr String)
metaVar     = String -> RuleExpr String
forall a. a -> RuleExpr a
MetaVar (String -> RuleExpr String)
-> ParsecT String u Identity String
-> ParsecT String u Identity (RuleExpr String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> String)
-> ParsecT String u Identity Char
-> ParsecT String u Identity String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> String
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
lower
          metaListVar :: ParsecT String u Identity (RuleExpr String)
metaListVar = String -> RuleExpr String
forall a. a -> RuleExpr a
MetaListVar (String -> RuleExpr String)
-> ParsecT String u Identity String
-> ParsecT String u Identity (RuleExpr String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> String)
-> ParsecT String u Identity Char
-> ParsecT String u Identity String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> String
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
upper
          var :: ParsecT String u Identity (RuleExpr String)
var = String -> RuleExpr String
forall a. a -> RuleExpr a
Var (String -> RuleExpr String)
-> ParsecT String u Identity String
-> ParsecT String u Identity (RuleExpr String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (
                String -> ParsecT String u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"["
            ParsecT String u Identity String
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> ParsecT String u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"]"
            ParsecT String u Identity String
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
                  String
x <- String -> ParsecT String u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"="
                  ParsecT String u Identity String -> ParsecT String u Identity ()
forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy (String -> ParsecT String u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
">")
                  String -> ParsecT String u Identity String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
x
            ParsecT String u Identity String
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT String u Identity Char -> ParsecT String u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
            ParsecT String u Identity String
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((:) (Char -> ShowS)
-> ParsecT String u Identity Char
-> ParsecT String u Identity ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
lower ParsecT String u Identity ShowS
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT String u Identity Char -> ParsecT String u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum)
            )
          ruleSep :: ParsecT String u Identity (RuleExpr a)
ruleSep = RuleExpr a
forall a. RuleExpr a
RuleSep RuleExpr a
-> ParsecT String u Identity String
-> ParsecT String u Identity (RuleExpr a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ParsecT String u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"=>"
          condSep :: ParsecT String u Identity (RuleExpr a)
condSep = RuleExpr a
forall a. RuleExpr a
CondSep RuleExpr a
-> ParsecT String u Identity String
-> ParsecT String u Identity (RuleExpr a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ParsecT String u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
":-"
      in  ParsecT String u Identity (RuleExpr String)
-> ParsecT String u Identity ()
-> ParsecT String u Identity [RuleExpr String]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy (ParsecT String u Identity (RuleExpr String)
-> ParsecT String u Identity (RuleExpr String)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT String u Identity (RuleExpr String)
forall u. ParsecT String u Identity (RuleExpr String)
var ParsecT String u Identity (RuleExpr String)
-> ParsecT String u Identity (RuleExpr String)
-> ParsecT String u Identity (RuleExpr String)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT String u Identity (RuleExpr String)
forall u. ParsecT String u Identity (RuleExpr String)
metaVar ParsecT String u Identity (RuleExpr String)
-> ParsecT String u Identity (RuleExpr String)
-> ParsecT String u Identity (RuleExpr String)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT String u Identity (RuleExpr String)
forall u. ParsecT String u Identity (RuleExpr String)
metaListVar ParsecT String u Identity (RuleExpr String)
-> ParsecT String u Identity (RuleExpr String)
-> ParsecT String u Identity (RuleExpr String)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT String u Identity (RuleExpr String)
forall u a. ParsecT String u Identity (RuleExpr a)
ruleSep ParsecT String u Identity (RuleExpr String)
-> ParsecT String u Identity (RuleExpr String)
-> ParsecT String u Identity (RuleExpr String)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT String u Identity (RuleExpr String)
forall u a. ParsecT String u Identity (RuleExpr a)
condSep) ParsecT String u Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces

-- An atom in a Rule
data RuleExpr a =
      Var a -- matches with one exact atom, e.g. "swap"
    | MetaVar a -- can match with any single atom and assign it to the variable name
    | MetaListVar a -- matches a list of atoms and assigns it to the variable name
    | RuleSep -- "=>"
    | CondSep -- ":-" (read as "if")
    deriving (Int -> RuleExpr a -> ShowS
[RuleExpr a] -> ShowS
RuleExpr a -> String
(Int -> RuleExpr a -> ShowS)
-> (RuleExpr a -> String)
-> ([RuleExpr a] -> ShowS)
-> Show (RuleExpr a)
forall a. Show a => Int -> RuleExpr a -> ShowS
forall a. Show a => [RuleExpr a] -> ShowS
forall a. Show a => RuleExpr a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RuleExpr a] -> ShowS
$cshowList :: forall a. Show a => [RuleExpr a] -> ShowS
show :: RuleExpr a -> String
$cshow :: forall a. Show a => RuleExpr a -> String
showsPrec :: Int -> RuleExpr a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> RuleExpr a -> ShowS
Show, RuleExpr a -> RuleExpr a -> Bool
(RuleExpr a -> RuleExpr a -> Bool)
-> (RuleExpr a -> RuleExpr a -> Bool) -> Eq (RuleExpr a)
forall a. Eq a => RuleExpr a -> RuleExpr a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RuleExpr a -> RuleExpr a -> Bool
$c/= :: forall a. Eq a => RuleExpr a -> RuleExpr a -> Bool
== :: RuleExpr a -> RuleExpr a -> Bool
$c== :: forall a. Eq a => RuleExpr a -> RuleExpr a -> Bool
Eq, Eq (RuleExpr a)
Eq (RuleExpr a)
-> (RuleExpr a -> RuleExpr a -> Ordering)
-> (RuleExpr a -> RuleExpr a -> Bool)
-> (RuleExpr a -> RuleExpr a -> Bool)
-> (RuleExpr a -> RuleExpr a -> Bool)
-> (RuleExpr a -> RuleExpr a -> Bool)
-> (RuleExpr a -> RuleExpr a -> RuleExpr a)
-> (RuleExpr a -> RuleExpr a -> RuleExpr a)
-> Ord (RuleExpr a)
RuleExpr a -> RuleExpr a -> Bool
RuleExpr a -> RuleExpr a -> Ordering
RuleExpr a -> RuleExpr a -> RuleExpr a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (RuleExpr a)
forall a. Ord a => RuleExpr a -> RuleExpr a -> Bool
forall a. Ord a => RuleExpr a -> RuleExpr a -> Ordering
forall a. Ord a => RuleExpr a -> RuleExpr a -> RuleExpr a
min :: RuleExpr a -> RuleExpr a -> RuleExpr a
$cmin :: forall a. Ord a => RuleExpr a -> RuleExpr a -> RuleExpr a
max :: RuleExpr a -> RuleExpr a -> RuleExpr a
$cmax :: forall a. Ord a => RuleExpr a -> RuleExpr a -> RuleExpr a
>= :: RuleExpr a -> RuleExpr a -> Bool
$c>= :: forall a. Ord a => RuleExpr a -> RuleExpr a -> Bool
> :: RuleExpr a -> RuleExpr a -> Bool
$c> :: forall a. Ord a => RuleExpr a -> RuleExpr a -> Bool
<= :: RuleExpr a -> RuleExpr a -> Bool
$c<= :: forall a. Ord a => RuleExpr a -> RuleExpr a -> Bool
< :: RuleExpr a -> RuleExpr a -> Bool
$c< :: forall a. Ord a => RuleExpr a -> RuleExpr a -> Bool
compare :: RuleExpr a -> RuleExpr a -> Ordering
$ccompare :: forall a. Ord a => RuleExpr a -> RuleExpr a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (RuleExpr a)
Ord, a -> RuleExpr b -> RuleExpr a
(a -> b) -> RuleExpr a -> RuleExpr b
(forall a b. (a -> b) -> RuleExpr a -> RuleExpr b)
-> (forall a b. a -> RuleExpr b -> RuleExpr a) -> Functor RuleExpr
forall a b. a -> RuleExpr b -> RuleExpr a
forall a b. (a -> b) -> RuleExpr a -> RuleExpr b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> RuleExpr b -> RuleExpr a
$c<$ :: forall a b. a -> RuleExpr b -> RuleExpr a
fmap :: (a -> b) -> RuleExpr a -> RuleExpr b
$cfmap :: forall a b. (a -> b) -> RuleExpr a -> RuleExpr b
Functor)

-- Stores the associations between rule variables and their matched Joy code
type RuleMap a = Map (RuleExpr a) [a]

-- | Given a list of rewrite rules and Joy code, apply the rules and return the resulting
--   list of tokens.
rewrite :: [Text] -> Text -> Either Error [Text]
rewrite :: [Text] -> Text -> Either Text [Text]
rewrite [Text]
ruleStrs Text
code = do
  [Rule]
rs <- (Text -> Either Text Rule) -> [Text] -> Either Text [Rule]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> Either Text Rule
mkRule [Text]
ruleStrs
  [Rule] -> [Text] -> Either Text [Text]
rewrite' [Rule]
rs (Text -> [Text]
tokenize Text
code) where

  rewrite' :: [Rule] -> [Text] -> Either Error [Text]
  rewrite' :: [Rule] -> [Text] -> Either Text [Text]
rewrite' [Rule]
rules = ([[Text]] -> [Text]) -> Either Text [[Text]] -> Either Text [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Either Text [[Text]] -> Either Text [Text])
-> ([Text] -> Either Text [[Text]]) -> [Text] -> Either Text [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> Either Text (Maybe ([Text], [Text])))
-> [Text] -> Either Text [[Text]]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe (b, a))) -> a -> m [b]
unfoldrM
    (\case
      [] -> Maybe ([Text], [Text]) -> Either Text (Maybe ([Text], [Text]))
forall a b. b -> Either a b
Right Maybe ([Text], [Text])
forall a. Maybe a
Nothing
      xxs :: [Text]
xxs@(Text
x : [Text]
xs) ->
        Maybe ([Text], [Text]) -> Either Text (Maybe ([Text], [Text]))
forall a b. b -> Either a b
Right (Maybe ([Text], [Text]) -> Either Text (Maybe ([Text], [Text])))
-> Maybe ([Text], [Text]) -> Either Text (Maybe ([Text], [Text]))
forall a b. (a -> b) -> a -> b
$ [Maybe ([Text], [Text])] -> Maybe ([Text], [Text])
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ((Rule -> Maybe ([Text], [Text]))
-> [Rule] -> [Maybe ([Text], [Text])]
forall a b. (a -> b) -> [a] -> [b]
map (\Rule
r -> case Rule -> [Text] -> Either Text ([Text], RuleMap Text)
matchPat Rule
r [Text]
xxs of
                    Right ([Text]
s, RuleMap Text
m) -> do
                      case Rule -> Maybe Condition
condition Rule
r of
                        Maybe Condition
Nothing -> ([Text], [Text]) -> Maybe ([Text], [Text])
forall a. a -> Maybe a
Just ((RuleExpr Text -> [Text]) -> [RuleExpr Text] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\RuleExpr Text
k -> case RuleExpr Text
k of
                            Var Text
k' -> [Text] -> RuleExpr Text -> RuleMap Text -> [Text]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [Text
k'] RuleExpr Text
k RuleMap Text
m
                            RuleExpr Text
_      -> RuleMap Text
m RuleMap Text -> RuleExpr Text -> [Text]
forall k a. Ord k => Map k a -> k -> a
M.! RuleExpr Text
k
                            )
                            (Rule -> [RuleExpr Text]
repl Rule
r)
                          , Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
s) [Text]
xxs
                          )
                        Just Condition
c -> case [Rule] -> [Text] -> Either Text [Text]
rewrite' [Rule]
rules (RuleMap Text -> [RuleExpr Text] -> [Text]
apply RuleMap Text
m ([RuleExpr Text] -> [Text]) -> [RuleExpr Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Condition -> [RuleExpr Text]
premise Condition
c) of
                          Right [Text]
x' -> case Rule -> [Text] -> Either Text ([Text], RuleMap Text)
matchConclusion Rule
r [Text]
x' of
                            Right ([Text]
_, RuleMap Text
m') -> ([Text], [Text]) -> Maybe ([Text], [Text])
forall a. a -> Maybe a
Just ([Text]
replTokens, Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
s) [Text]
xxs)
                              where replTokens :: [Text]
replTokens = RuleMap Text -> [RuleExpr Text] -> [Text]
apply (RuleMap Text -> RuleMap Text -> RuleMap Text
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union RuleMap Text
m RuleMap Text
m') ([RuleExpr Text] -> [Text]) -> [RuleExpr Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Rule -> [RuleExpr Text]
repl Rule
r
                            Either Text ([Text], RuleMap Text)
_ -> Maybe ([Text], [Text])
forall a. Maybe a
Nothing
                          Either Text [Text]
_ -> Maybe ([Text], [Text])
forall a. Maybe a
Nothing
                    Either Text ([Text], RuleMap Text)
_ -> Maybe ([Text], [Text])
forall a. Maybe a
Nothing
                  ) [Rule]
rules
                )
          Maybe ([Text], [Text])
-> Maybe ([Text], [Text]) -> Maybe ([Text], [Text])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ([Text], [Text]) -> Maybe ([Text], [Text])
forall a. a -> Maybe a
Just ([Text
x], [Text]
xs)
    )

  -- Applies the stored rewrite associations to Joy code.
  apply :: RuleMap Text -> [RuleExpr Text] -> [Text]
  apply :: RuleMap Text -> [RuleExpr Text] -> [Text]
apply RuleMap Text
m = (RuleExpr Text -> [Text]) -> [RuleExpr Text] -> [Text]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
(=<<) (\RuleExpr Text
x -> [Text] -> RuleExpr Text -> RuleMap Text -> [Text]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [(\case (Var Text
x') -> Text
x') RuleExpr Text
x] RuleExpr Text
x RuleMap Text
m)

  -- Matches the pattern part of a rule. I didn't find anything like `runState`
  -- for Parsec, so I return both the value and the state in the same tuple
  -- format.
  matchPat :: Rule -> [Text] -> Either Error ([Text], RuleMap Text)
  matchPat :: Rule -> [Text] -> Either Text ([Text], RuleMap Text)
matchPat Rule
r = Either ParseError ([Text], RuleMap Text)
-> Either Text ([Text], RuleMap Text)
forall a. Either ParseError a -> Either Text a
convertError (Either ParseError ([Text], RuleMap Text)
 -> Either Text ([Text], RuleMap Text))
-> ([Text] -> Either ParseError ([Text], RuleMap Text))
-> [Text]
-> Either Text ([Text], RuleMap Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec [Text] (RuleMap Text) ([Text], RuleMap Text)
-> RuleMap Text
-> String
-> [Text]
-> Either ParseError ([Text], RuleMap Text)
forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> String -> s -> Either ParseError a
runParser
    (do
      [Text]
x <- [RuleExpr Text] -> Parsec [Text] (RuleMap Text) [Text]
mkParser (Rule -> [RuleExpr Text]
pat Rule
r)
      RuleMap Text
y <- ParsecT [Text] (RuleMap Text) Identity (RuleMap Text)
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
      ([Text], RuleMap Text)
-> Parsec [Text] (RuleMap Text) ([Text], RuleMap Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text]
x, RuleMap Text
y)
    )
    RuleMap Text
forall k a. Map k a
M.empty
    String
""

  matchConclusion
    :: Rule -> [Text] -> Either Error ([Text], RuleMap Text)
  matchConclusion :: Rule -> [Text] -> Either Text ([Text], RuleMap Text)
matchConclusion Rule
r [Text]
xs = do
    [RuleExpr Text]
conc <- Condition -> [RuleExpr Text]
conclusion (Condition -> [RuleExpr Text])
-> Either Text Condition -> Either Text [RuleExpr Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Condition -> Either Text Condition
forall a. Maybe a -> Either Text a
maybeToParseResult (Rule -> Maybe Condition
condition Rule
r)
    Either ParseError ([Text], RuleMap Text)
-> Either Text ([Text], RuleMap Text)
forall a. Either ParseError a -> Either Text a
convertError (Either ParseError ([Text], RuleMap Text)
 -> Either Text ([Text], RuleMap Text))
-> Either ParseError ([Text], RuleMap Text)
-> Either Text ([Text], RuleMap Text)
forall a b. (a -> b) -> a -> b
$ Parsec [Text] (RuleMap Text) ([Text], RuleMap Text)
-> RuleMap Text
-> String
-> [Text]
-> Either ParseError ([Text], RuleMap Text)
forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> String -> s -> Either ParseError a
runParser
      (do
        [Text]
x <- [RuleExpr Text] -> Parsec [Text] (RuleMap Text) [Text]
mkParser [RuleExpr Text]
conc
        RuleMap Text
y <- ParsecT [Text] (RuleMap Text) Identity (RuleMap Text)
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
        ([Text], RuleMap Text)
-> Parsec [Text] (RuleMap Text) ([Text], RuleMap Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text]
x, RuleMap Text
y)
      )
      RuleMap Text
forall k a. Map k a
M.empty
      String
""
      [Text]
xs where
    -- I think this is also a clear case where I should use a more generic error
    -- type.
    maybeToParseResult :: Maybe a -> Either Error a
    maybeToParseResult :: Maybe a -> Either Text a
maybeToParseResult = Either Text a -> (a -> Either Text a) -> Maybe a -> Either Text a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text a
forall a b. a -> Either a b
Left Text
"") a -> Either Text a
forall a b. b -> Either a b
Right

  mkParser :: [RuleExpr Text] -> Parsec [Text] (RuleMap Text) [Text]
  mkParser :: [RuleExpr Text] -> Parsec [Text] (RuleMap Text) [Text]
mkParser = (RuleExpr Text
 -> Parsec [Text] (RuleMap Text) [Text]
 -> Parsec [Text] (RuleMap Text) [Text])
-> Parsec [Text] (RuleMap Text) [Text]
-> [RuleExpr Text]
-> Parsec [Text] (RuleMap Text) [Text]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
    (\RuleExpr Text
x Parsec [Text] (RuleMap Text) [Text]
acc -> case RuleExpr Text
x of
      Var Text
x' -> do
        (RuleMap Text -> RuleMap Text)
-> ParsecT [Text] (RuleMap Text) Identity ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState ((RuleMap Text -> RuleMap Text)
 -> ParsecT [Text] (RuleMap Text) Identity ())
-> (RuleMap Text -> RuleMap Text)
-> ParsecT [Text] (RuleMap Text) Identity ()
forall a b. (a -> b) -> a -> b
$ RuleExpr Text -> [Text] -> RuleMap Text -> RuleMap Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Text -> RuleExpr Text
forall a. a -> RuleExpr a
Var Text
x') [Text
x']
        (:) (Text -> [Text] -> [Text])
-> ParsecT [Text] (RuleMap Text) Identity Text
-> ParsecT [Text] (RuleMap Text) Identity ([Text] -> [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ParsecT [Text] (RuleMap Text) Identity Text
forall a u. (Eq a, Show a) => a -> Parsec [a] u a
char' Text
x' ParsecT [Text] (RuleMap Text) Identity ([Text] -> [Text])
-> Parsec [Text] (RuleMap Text) [Text]
-> Parsec [Text] (RuleMap Text) [Text]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parsec [Text] (RuleMap Text) [Text]
acc
      MetaVar Text
x' -> do
        -- `nonBracket'` and `nonTrueNonBracket'` are hacks because I couldn't
        -- figure out how to reluctantly match as little as possible. I think
        -- the parser-combinators package might contain what I need.
        Text
x'' <- ParsecT [Text] (RuleMap Text) Identity Text
forall u. Parsec [Text] u Text
nonBracket'
        (RuleMap Text -> RuleMap Text)
-> ParsecT [Text] (RuleMap Text) Identity ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState ((RuleMap Text -> RuleMap Text)
 -> ParsecT [Text] (RuleMap Text) Identity ())
-> (RuleMap Text -> RuleMap Text)
-> ParsecT [Text] (RuleMap Text) Identity ()
forall a b. (a -> b) -> a -> b
$ RuleExpr Text -> [Text] -> RuleMap Text -> RuleMap Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Text -> RuleExpr Text
forall a. a -> RuleExpr a
MetaVar Text
x') [Text
x'']
        (Text
x'' Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) ([Text] -> [Text])
-> Parsec [Text] (RuleMap Text) [Text]
-> Parsec [Text] (RuleMap Text) [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec [Text] (RuleMap Text) [Text]
acc
      MetaListVar Text
x' -> do
        [Text]
x'' <- ParsecT [Text] (RuleMap Text) Identity Text
-> Parsec [Text] (RuleMap Text) [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParsecT [Text] (RuleMap Text) Identity Text
forall u. Parsec [Text] u Text
nonTrueNonBracket'
        (RuleMap Text -> RuleMap Text)
-> ParsecT [Text] (RuleMap Text) Identity ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
modifyState ((RuleMap Text -> RuleMap Text)
 -> ParsecT [Text] (RuleMap Text) Identity ())
-> (RuleMap Text -> RuleMap Text)
-> ParsecT [Text] (RuleMap Text) Identity ()
forall a b. (a -> b) -> a -> b
$ RuleExpr Text -> [Text] -> RuleMap Text -> RuleMap Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Text -> RuleExpr Text
forall a. a -> RuleExpr a
MetaListVar Text
x') [Text]
x''
        ([Text]
x'' [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++) ([Text] -> [Text])
-> Parsec [Text] (RuleMap Text) [Text]
-> Parsec [Text] (RuleMap Text) [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec [Text] (RuleMap Text) [Text]
acc
      RuleExpr Text
RuleSep -> String -> Parsec [Text] (RuleMap Text) [Text]
forall a. HasCallStack => String -> a
error String
"assertion error: RuleSep found by mkParser"
      RuleExpr Text
CondSep -> String -> Parsec [Text] (RuleMap Text) [Text]
forall a. HasCallStack => String -> a
error String
"assertion error: CondSep found by mkParser"
    )
    ([Text] -> Parsec [Text] (RuleMap Text) [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])

-- | Split Joy code into tokens.
tokenize :: Text -> [Text]
tokenize :: Text -> [Text]
tokenize = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
tokenize' where

  tokenize' :: Text -> [Text]
  tokenize' :: Text -> [Text]
tokenize' = (Text -> Maybe (Text, Text)) -> Text -> [Text]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr
    (\Text
xxs -> case Text -> Maybe (Char, Text)
T.uncons Text
xxs of
      Maybe (Char, Text)
Nothing        -> Maybe (Text, Text)
forall a. Maybe a
Nothing
      Just (Char
'[', Text
xs) -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
"[", Text
xs)
      Just (Char
']', Text
xs) -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
"]", Text
xs)
      Just (Char, Text)
_   -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
a, (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Text
b)
        where (Text
a, Text
b) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"[] " :: String)) Text
xxs
    )

-- I ended these with an apostrophe, because they work on tokens, not Strings.
satisfy' :: (Eq a, Show a) => (a -> Bool) -> Parsec [a] u a
satisfy' :: (a -> Bool) -> Parsec [a] u a
satisfy' a -> Bool
p = (a -> String)
-> (SourcePos -> a -> [a] -> SourcePos)
-> (a -> Maybe a)
-> Parsec [a] u a
forall s (m :: * -> *) t a u.
Stream s m t =>
(t -> String)
-> (SourcePos -> t -> s -> SourcePos)
-> (t -> Maybe a)
-> ParsecT s u m a
tokenPrim a -> String
forall a. Show a => a -> String
showTok SourcePos -> a -> [a] -> SourcePos
forall p p. SourcePos -> p -> p -> SourcePos
posFromTok a -> Maybe a
testTok
 where
  showTok :: a -> String
showTok a
t = a -> String
forall a. Show a => a -> String
show a
t
  posFromTok :: SourcePos -> p -> p -> SourcePos
posFromTok SourcePos
pos p
_ p
_ = SourcePos -> Int -> SourcePos
incSourceColumn SourcePos
pos Int
1
  testTok :: a -> Maybe a
testTok a
t = (a -> Bool) -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
mfilter a -> Bool
p (a -> Maybe a
forall a. a -> Maybe a
Just a
t)

char' :: (Eq a, Show a) => a -> Parsec [a] u a
char' :: a -> Parsec [a] u a
char' a
x = (a -> Bool) -> Parsec [a] u a
forall a u. (Eq a, Show a) => (a -> Bool) -> Parsec [a] u a
satisfy' (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x) Parsec [a] u a -> String -> Parsec [a] u a
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> a -> String
forall a. Show a => a -> String
show a
x

nonBracket' :: Parsec [Text] u Text
nonBracket' :: Parsec [Text] u Text
nonBracket' = (Text -> Bool) -> Parsec [Text] u Text
forall a u. (Eq a, Show a) => (a -> Bool) -> Parsec [a] u a
satisfy' (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text
"[", Text
"]"])

nonTrueNonBracket' :: Parsec [Text] u Text
nonTrueNonBracket' :: Parsec [Text] u Text
nonTrueNonBracket' = (Text -> Bool) -> Parsec [Text] u Text
forall a u. (Eq a, Show a) => (a -> Bool) -> Parsec [a] u a
satisfy' (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text
"[", Text
"]", Text
"true"])