joy-rewrite (empty) → 0.1.0.0
raw patch · 5 files changed
+416/−0 lines, 5 filesdep +basedep +containersdep +hspec
Dependencies added: base, containers, hspec, joy-rewrite, monad-loops, parsec, text
Files
- CHANGELOG.md +5/−0
- LICENSE +26/−0
- joy-rewrite.cabal +76/−0
- src/Language/Joy/Rewrite.hs +224/−0
- test/RewriteTest.hs +85/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for joy-rewrite++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2022, Johannes Riecken+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. 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.++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.
+ joy-rewrite.cabal view
@@ -0,0 +1,76 @@+cabal-version: 2.4++name: joy-rewrite++version: 0.1.0.0++synopsis: Transform Joy code using conditional rewrite rules++description:+ This package implements a rewriting function as detailed in the paper [A+ Rewriting System for Joy](http://www.nsl.com/papers/rewritejoy.html) by Manfred+ von Thun. It can be used to simplify expressions or to replace constant+ expressions by their results.++homepage: https://github.com/johannes-riecken/joy-rewrite++bug-reports: https://github.com/johannes-riecken/joy-rewrite/issues++license: BSD-2-Clause++license-file: LICENSE++author: Johannes Riecken++maintainer: johannes.riecken@gmail.com++category: Language++extra-source-files: CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/johannes-riecken/joy-rewrite.git++library+ exposed-modules: Language.Joy.Rewrite++ -- Modules included in this library but not exported.+ -- other-modules:++ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:++ -- Other library packages from which modules are imported.+ build-depends:+ base ^>=4.14.3.0,+ containers ^>= 0.6.5.1,+ monad-loops ^>= 0.4.3,+ hspec ^>= 2.8.3,+ parsec ^>= 3.1.14.0,+ text ^>= 1.2.4++ -- Directories containing source files.+ hs-source-dirs: src++ -- Base language which the package is written in.+ default-language: Haskell2010++test-suite joy-rewrite-test+ -- Base language which the package is written in.+ default-language: Haskell2010++ -- The interface type and version of the test suite.+ type: exitcode-stdio-1.0++ -- Directories containing source files.+ hs-source-dirs: test++ -- The entrypoint to the test suite.+ main-is: RewriteTest.hs++ -- Test dependencies.+ build-depends:+ base ^>=4.14.3.0,+ joy-rewrite,+ hspec ^>= 2.8.3
+ src/Language/Joy/Rewrite.hs view
@@ -0,0 +1,224 @@+{-# 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+ { pat :: [RuleExpr Text]+ , repl :: [RuleExpr Text]+ , condition :: Maybe Condition+ }+ deriving Show++data Condition = Condition+ { premise :: [RuleExpr Text]+ , conclusion :: [RuleExpr Text]+ }+ deriving Show++convertError :: Either ParseError a -> Either Error a+convertError (Left x) = Left . T.pack $ show x+convertError (Right x) = Right x++-- Construct a Rule by parsing a string like "a b swap => b a"+mkRule :: Text -> Either Error Rule+mkRule xs = do+ xs' <- tokenizeRule xs+ if CondSep `elem` xs'+ then do+ (v,w) <- cut CondSep xs'+ (a,b) <- cut RuleSep v+ (c,d) <- cut RuleSep w+ pure $ Rule a b (Just $ Condition c d)+ else do+ (a, b) <- tokenizeFromTo xs+ pure $ Rule a b Nothing where++ tokenizeFromTo :: Text -> Either Error ([RuleExpr Text], [RuleExpr Text])+ tokenizeFromTo xs = tokenizeRule xs >>= cut RuleSep++ cut :: Eq a => a -> [a] -> Either Error ([a], [a])+ cut _ [] = Left "tried to cut empty list"+ cut sep xs = Right . second tail . break (== sep) $ xs++ tokenizeRule :: Text -> Either Error [RuleExpr Text]+ tokenizeRule = convertError . fmap (fmap (fmap T.pack)) . parse parser "" . T.unpack where+ parser =+ let metaVar = MetaVar <$> fmap pure lower+ metaListVar = MetaListVar <$> fmap pure upper+ var = Var <$> (+ string "["+ <|> string "]"+ <|> do+ x <- string "="+ notFollowedBy (string ">")+ pure x+ <|> many1 digit+ <|> ((:) <$> lower <*> many1 alphaNum)+ )+ ruleSep = RuleSep <$ string "=>"+ condSep = CondSep <$ string ":-"+ in sepBy (try var <|> metaVar <|> metaListVar <|> ruleSep <|> condSep) 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 (Show, Eq, Ord, 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 ruleStrs code = do+ rs <- traverse mkRule ruleStrs+ rewrite' rs (tokenize code) where++ rewrite' :: [Rule] -> [Text] -> Either Error [Text]+ rewrite' rules = fmap concat . unfoldrM+ (\case+ [] -> Right Nothing+ xxs@(x : xs) ->+ Right $ asum (map (\r -> case matchPat r xxs of+ Right (s, m) -> do+ case condition r of+ Nothing -> Just (concatMap (\k -> case k of+ Var k' -> M.findWithDefault [k'] k m+ _ -> m M.! k+ )+ (repl r)+ , drop (length s) xxs+ )+ Just c -> case rewrite' rules (apply m $ premise c) of+ Right x' -> case matchConclusion r x' of+ Right (_, m') -> Just (replTokens, drop (length s) xxs)+ where replTokens = apply (M.union m m') $ repl r+ _ -> Nothing+ _ -> Nothing+ _ -> Nothing+ ) rules+ )+ <|> Just ([x], xs)+ )++ -- Applies the stored rewrite associations to Joy code.+ apply :: RuleMap Text -> [RuleExpr Text] -> [Text]+ apply m = (=<<) (\x -> M.findWithDefault [(\case (Var x') -> x') x] x 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 r = convertError . runParser+ (do+ x <- mkParser (pat r)+ y <- getState+ pure (x, y)+ )+ M.empty+ ""++ matchConclusion+ :: Rule -> [Text] -> Either Error ([Text], RuleMap Text)+ matchConclusion r xs = do+ conc <- conclusion <$> maybeToParseResult (condition r)+ convertError $ runParser+ (do+ x <- mkParser conc+ y <- getState+ pure (x, y)+ )+ M.empty+ ""+ 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 (Left "") Right++ mkParser :: [RuleExpr Text] -> Parsec [Text] (RuleMap Text) [Text]+ mkParser = foldr+ (\x acc -> case x of+ Var x' -> do+ modifyState $ M.insert (Var x') [x']+ (:) <$> char' x' <*> acc+ MetaVar 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.+ x'' <- nonBracket'+ modifyState $ M.insert (MetaVar x') [x'']+ (x'' :) <$> acc+ MetaListVar x' -> do+ x'' <- many nonTrueNonBracket'+ modifyState $ M.insert (MetaListVar x') x''+ (x'' ++) <$> acc+ RuleSep -> error "assertion error: RuleSep found by mkParser"+ CondSep -> error "assertion error: CondSep found by mkParser"+ )+ (pure [])++-- | Split Joy code into tokens.+tokenize :: Text -> [Text]+tokenize = filter (not . T.null) . tokenize' where++ tokenize' :: Text -> [Text]+ tokenize' = unfoldr+ (\xxs -> case T.uncons xxs of+ Nothing -> Nothing+ Just ('[', xs) -> Just ("[", xs)+ Just (']', xs) -> Just ("]", xs)+ Just _ -> Just (a, T.dropWhile (== ' ') b)+ where (a, b) = T.break (`elem` ("[] " :: String)) 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' p = tokenPrim showTok posFromTok testTok+ where+ showTok t = show t+ posFromTok pos _ _ = incSourceColumn pos 1+ testTok t = mfilter p (Just t)++char' :: (Eq a, Show a) => a -> Parsec [a] u a+char' x = satisfy' (== x) <?> show x++nonBracket' :: Parsec [Text] u Text+nonBracket' = satisfy' (`notElem` ["[", "]"])++nonTrueNonBracket' :: Parsec [Text] u Text+nonTrueNonBracket' = satisfy' (`notElem` ["[", "]", "true"])
+ test/RewriteTest.hs view
@@ -0,0 +1,85 @@+module Main (main) where++import Language.Joy.Rewrite+import Test.Hspec++main :: IO ()+main = do+ hspec $ do++ describe "empty param" $ do+ it "rewrites"+ $ (do+ let r0 = "[] [M] concat => [M]"+ let r1 = "[a L] [M] concat => [a N] :- [L] [M] concat => [N]"+ rewrite [r0, r1] "[] [1 2] concat"+ )+ `shouldBe` Right (tokenize "[1 2]")++ describe "single elem" $ do+ it "rewrites"+ $ (do+ let r0 = "[] [M] concat => [M]"+ let r1 = "[a L] [M] concat => [a N] :- [L] [M] concat => [N]"+ rewrite [r0, r1] "[1] [2 3] concat"+ )+ `shouldBe` Right (tokenize "[1 2 3]")+ it "rewrites multiple elems"+ $ (do+ let r0 = "[] [M] concat => [M]"+ let r1 = "[a L] [M] concat => [a N] :- [L] [M] concat => [N]"+ rewrite [r0, r1] "[1 2] [3 4] concat"+ )+ `shouldBe` Right (tokenize "[1 2 3 4]")+ it "rewrites ifte"+ $ (do+ let r0 = "a a = => true"+ let r1 = "L [I] [T] [E] ifte => L T :- L I => M true"+ rewrite [r0, r1] "1 1 [=] [5] [6] ifte"+ )+ `shouldBe` Right (tokenize "1 1 5")+ it "returns original if nothing to rewrite"+ $ (do+ let r0 = "a a = => true"+ let r1 = "L [I] [T] [E] ifte => L T :- L I => M true"+ rewrite [r0, r1] "1 2 3 4 5"+ )+ `shouldBe` Right (tokenize "1 2 3 4 5")+ it "substitutes given strings" $ do+ rewrite ["a b swap => b a"] "foo bar swap" `shouldBe` Right ["bar", "foo"]+ rewrite ["a b swap => b a"] "foo bar swap baz quux"+ `shouldBe` Right ["bar", "foo", "baz", "quux"]+ rewrite ["a b swap => b a"] "red green foo bar swap baz quux"+ `shouldBe` Right ["red", "green", "bar", "foo", "baz", "quux"]+ rewrite ["a b swap => b a"] "3 4 swap" `shouldBe` Right ["4", "3"]+ rewrite ["a b => [b] a"] "a b s"+ `shouldBe` Right ["[", "b", "]", "a", "s"]+ rewrite ["a b => b a"] "a b swap" `shouldBe` Right ["b", "a", "swap"]+ rewrite ["a b => b"] "a b s" `shouldBe` Right ["b", "s"]+ rewrite ["a b => b a b a"] "a b s"+ `shouldBe` Right ["b", "a", "b", "a", "s"]+ rewrite ["a [P] dip => P a"] "a [b c] dip"+ `shouldBe` Right ["b", "c", "a"]+ rewrite ["[ ] unstack => newstack"] "[] unstack"+ `shouldBe` Right ["newstack"]+ rewrite ["[a b L] second => b"] "1 [2 3 4 5] second"+ `shouldBe` Right ["1", "3"]+ rewrite ["[a L] 1 at => a"] "[2 3 4] 1 at" `shouldBe` Right ["2"]+ rewrite ["[] [L] concat => [L]"] "[ ] [1 2 3] concat"+ `shouldBe` Right ["[", "1", "2", "3", "]"]++ it "keeps trailing stuff" $ do+ rewrite+ [ "[] [M] concat => [M]"+ , "[a L] [M] concat => [a N] :- [L] [M] concat => [N]"+ ]+ "[1 2] [3 4] concat 5 6"+ `shouldBe` Right (tokenize "[1 2 3 4] 5 6")+ it "rewrites in the middle" $ do+ rewrite+ [ "[] [M] concat => [M]"+ , "[a L] [M] concat => [a N] :- [L] [M] concat => [N]"+ ]+ "1 2 [3 4] [5 6 7] concat 8 9"+ `shouldBe` Right (tokenize "1 2 [3 4 5 6 7] 8 9")+ pure ()