pointfree-fancy 1.1.1.7 → 1.1.1.8

raw patch · 17 files changed

+1567/−1579 lines, 17 filesdep +pointfree-fancydep ~basedep ~containersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: pointfree-fancy

Dependency ranges changed: base, containers

API changes (from Hackage documentation)

Files

• Main.hs +10/−10
• Plugin/Pl/Common.hs +0/−133
• Plugin/Pl/Optimize.hs +0/−102
• Plugin/Pl/Parser.hs +0/−92
• Plugin/Pl/PrettyPrinter.hs +0/−146
• Plugin/Pl/Rules.hs +0/−875
• Plugin/Pl/Transform.hs +0/−146
• Pointfree.hs +0/−31
• lib/Pointfree.hs +30/−0
• pointfree-fancy.cabal +24/−29
• src/Plugin/Pl/Common.hs +130/−0
• src/Plugin/Pl/Optimize.hs +102/−0
• src/Plugin/Pl/Parser.hs +92/−0
• src/Plugin/Pl/PrettyPrinter.hs +146/−0
• src/Plugin/Pl/Rules.hs +875/−0
• src/Plugin/Pl/Transform.hs +146/−0
• test/Test.hs +12/−15

@@ -1,15 +1,15 @@ module Main where -import Plugin.Pl.Common-import Plugin.Pl.Optimize-import Plugin.Pl.Parser-import Plugin.Pl.PrettyPrinter-import Plugin.Pl.Transform--import System.Environment (getArgs)-import System.Console.GetOpt+import           Data.Foldable+import           Plugin.Pl.Common+import           Plugin.Pl.Optimize+import           Plugin.Pl.Parser+import           Plugin.Pl.PrettyPrinter+import           Plugin.Pl.Transform+import           System.Console.GetOpt+import           System.Environment      (getArgs) -data Flag = Verbose +data Flag = Verbose           | StdIn   deriving Eq @@ -25,7 +25,7 @@ parseArgs args =   case getOpt Permute options args of     (flags, nonOptions, []) -> return (flags, nonOptions)-    (_, _, errs) -> ioError (userError (concat errs ++ usageInfo header options))+    (_, _, errs) -> ioError (userError (fold errs ++ usageInfo header options))  getQuery :: [Flag] -> [String] -> IO String getQuery flags nonOptions

@@ -1,133 +0,0 @@-module Plugin.Pl.Common (-        Fixity(..), Expr(..), Pattern(..), Decl(..), TopLevel(..),-        bt, mapTopLevel, mapTopLevel',-        lookupFix, minPrec, maxPrec,-        comp, flip', id', const', scomb, cons, nil, fix', if', readM,-        makeList, getList,-        Assoc(..),-        module Data.Maybe,-        module Control.Arrow,-        module Data.List,-        module Control.Monad,-        module GHC.Base-    ) where--import           Data.List             (intersperse, minimumBy)-import qualified Data.Map              as M-import           Data.Maybe            (fromJust, fromMaybe, isJust)--import           Control.Arrow         (first, second, (&&&), (***), (+++),-                                        (|||))-import           Control.Monad--import           Language.Haskell.Exts (Assoc (..))--import           GHC.Base              (assert)----- The rewrite rules can be found at the end of the file Rules.hs---- Not sure if passing the information if it was used as infix or prefix--- is worth threading through the whole thing is worth the effort,--- but it stays that way until the prettyprinting algorithm gets more--- sophisticated.-data Fixity = Pref | Inf deriving Show--instance Eq Fixity where-  _ == _ = True--instance Ord Fixity where-  compare _ _ = EQ--data Expr-  = Var Fixity String-  | Lambda Pattern Expr-  | App Expr Expr-  | Let [Decl] Expr-  deriving (Eq, Ord, Show)--data Pattern-  = PVar String-  | PCons Pattern Pattern-  | PTuple Pattern Pattern-  deriving (Eq, Ord, Show)--data Decl = Define {-  declName :: String,-  declExpr :: Expr-} deriving (Eq, Ord, Show)--data TopLevel = TLD Bool Decl | TLE Expr deriving (Eq, Ord, Show)--mapTopLevel :: (Expr -> Expr) -> TopLevel -> TopLevel-mapTopLevel f tl = case getExpr tl of (e, c) -> c $ f e--mapTopLevel' :: Functor f => (Expr -> f Expr) -> TopLevel -> f TopLevel-mapTopLevel' f tl = case getExpr tl of (e, c) -> c <$> f e--getExpr :: TopLevel -> (Expr, Expr -> TopLevel)-getExpr (TLD True (Define foo e)) = (Let [Define foo e] (Var Pref foo),-                                     TLD False . Define foo)-getExpr (TLD False (Define foo e)) = (e, TLD False . Define foo)-getExpr (TLE e)      = (e, TLE)--comp, flip', id', const', scomb, cons, nil, fix', if' :: Expr-comp   = Var Inf  "."-flip'  = Var Pref "flip"-id'    = Var Pref "id"-const' = Var Pref "const"-scomb  = Var Pref "ap"-cons   = Var Inf  ":"-nil    = Var Pref "[]"-fix'   = Var Pref "fix"-if'    = Var Pref "if'"--makeList :: [Expr] -> Expr-makeList = foldr (\e1 e2 -> cons `App` e1 `App` e2) nil---- Modularity is a drag-getList :: Expr -> ([Expr], Expr)-getList (c `App` x `App` tl) | c == cons = first (x:) $ getList tl-getList e                    = ([],e)--bt :: a-bt = undefined--shift, minPrec, maxPrec :: Int-shift = 0-maxPrec = shift + 10-minPrec = 0---- operator precedences are needed both for parsing and prettyprinting-operators :: [[(String, (Assoc (), Int))]]-operators = (map . map . second . second $ (+shift))-  [[inf "." (AssocRight ()) 9, inf "!!" (AssocLeft ()) 9],-   [inf name (AssocRight ()) 8 | name <- ["^", "^^", "**"]],-   [inf name (AssocLeft ()) 7-     | name <- ["*", "/", "`quot`", "`rem`", "`div`", "`mod`", ":%", "%"]],-   [inf name (AssocLeft ()) 6  | name <- ["+", "-"]],-   [inf name (AssocRight ()) 5 | name <- [":", "++"]],-   [inf name (AssocNone ()) 4-     | name <- ["==", "/=", "<", "<=", ">=", ">", "`elem`", "`notElem`"]],-   [inf "&&" (AssocRight ()) 3],-   [inf "||" (AssocRight ()) 2],-   [inf ">>" (AssocLeft ()) 1, inf ">>=" (AssocLeft ()) 1, inf "=<<" (AssocRight ()) 1],-   [inf name (AssocRight ()) 0 | name <- ["$", "$!", "`seq`"]]-  ] where-  inf name assoc fx = (name, (assoc, fx))--opFM :: M.Map String (Assoc (), Int)-opFM = M.fromList $ join operators--lookupOp :: String -> Maybe (Assoc (), Int)-lookupOp k = M.lookup k opFM--lookupFix :: String -> (Assoc (), Int)-lookupFix str = fromMaybe (AssocLeft (), 9 + shift) (lookupOp str)--readM :: (Monad m, Read a) => String -> m a-readM s = case [x | (x,t) <- reads s, ("","")  <- lex t] of-            [x] -> return x-            []  -> fail "readM: No parse."-            _   -> fail "readM: Ambiguous parse."-

@@ -1,102 +0,0 @@-{-# LANGUAGE ImplicitParams #-}-module Plugin.Pl.Optimize (-    optimize,-  ) where--import           Plugin.Pl.Common-import           Plugin.Pl.PrettyPrinter (prettyExpr)-import           Plugin.Pl.Rules--import           Data.List               (nub)--cut :: [a] -> [a]-cut = take 1--toMonadPlus :: MonadPlus m => Maybe a -> m a-toMonadPlus Nothing  = mzero-toMonadPlus (Just x)=return x--type Size = Integer--- This seems to be a better size for our purposes,--- despite being "a little" slower because of the wasteful uglyprinting-sizeExpr' :: Expr -> Size-sizeExpr' e = 100 * fromIntegral (length $ prettyExpr e) + adjust e where-  -- hackish thing to favor some expressions if the length is the same:-  -- (+ x) --> (x +)-  -- x >>= f --> f =<< x-  -- f $ g x --> f (g x)-  adjust :: Expr -> Size-  adjust (Var _ str) -- Just n <- readM str = log (n*n+1) / 4-                     | str == "uncurry"    = -400---                     | str == "s"          = 500-                     | str == "flip"       = 10-                     | str == ">>="        = 5-                     | str == "$"          = 1-                     | str == "subtract"   = 1-                     | str == "ap"         = 200-                     | str == "liftM2"     = 101-                     | str == "return"     = -200-                     | str == "zipWith"    = -400-                     | str == "const"      = 0 -- -200-                     | str == "fmap"       = -100-  adjust (Lambda _ e') = adjust e'-  adjust (App e1 e2)  = adjust e1 + adjust e2-  adjust _ = 0--optimize :: Expr -> [Expr]-optimize e = result where-  result :: [Expr]-  result = map (snd . fromJust) . takeWhile isJust .-    iterate ((=<<) simpleStep) $ Just (sizeExpr' e, e)--  simpleStep :: (Size, Expr) -> Maybe (Size, Expr)-  simpleStep t = do-    let chn = let ?first = True in step (snd t)-        chnn = let ?first = False in step =<< chn-        new = filter (\(x,_) -> x < fst t) . map (sizeExpr' &&& id) $-                snd t: chn ++ chnn-    case new of-      []       -> Nothing-      (new':_) -> return new'--step :: (?first :: Bool) => Expr -> [Expr]-step e = nub $ rewrite rules e--rewrite :: (?first :: Bool) => RewriteRule -> Expr -> [Expr]-rewrite rl e = case rl of-    Up r1 r2     -> let e'  = cut $ rewrite r1 e-                        e'' = rewrite r2 =<< e'-                    in if null e'' then e' else e''-    OrElse r1 r2 -> let e'  = rewrite r1 e-                    in if null e' then rewrite r2 e else e'-    Then r1 r2   -> rewrite r2 =<< nub (rewrite r1 e)-    Opt  r       -> e: rewrite r e-    If   p  r    -> if null (rewrite p e) then mzero else rewrite r e-    Hard r       -> if ?first then rewrite r e else mzero-    Or rs        -> (`rewrite` e) =<< rs-    RR {}        -> rewDeep rl e-    CRR {}       -> rewDeep rl e-    Down {}      -> rewDeep rl e--rewDeep :: (?first :: Bool) => RewriteRule -> Expr -> [Expr]-rewDeep rule e = rew rule e `mplus` case e of-    Var _ _    -> mzero-    Lambda _ _ -> error "lambda: optimizer only works for closed expressions"-    Let _ _    -> error "let: optimizer only works for closed expressions"-    App e1 e2  -> ((`App` e2) `map` rewDeep rule e1) `mplus`-                  ((e1 `App`) `map` rewDeep rule e2)--rew :: (?first :: Bool) => RewriteRule -> Expr -> [Expr]-rew (RR r1 r2) e = toMonadPlus $ fire r1 r2 e-rew (CRR r) e = toMonadPlus $ r e-rew (Or rs) e = (`rew` e) =<< rs-rew (Down r1 r2) e-  = if null e'' then e' else e'' where-    e'  = cut $ rew r1 e-    e'' = rewDeep r2 =<< e'-rew r@Then   {} e = rewrite r e-rew r@OrElse {} e = rewrite r e-rew r@Up     {} e = rewrite r e-rew r@Opt    {} e = rewrite r e-rew r@If     {} e = rewrite r e-rew r@Hard   {} e = rewrite r e

@@ -1,92 +0,0 @@-module Plugin.Pl.Parser (parsePF) where--import           Plugin.Pl.Common--import qualified Language.Haskell.Exts as HSE--todo :: (Functor e, Show (e ())) => e a -> r-todo thing = error ("pointfree: not supported: " ++ show (void thing))--nameString :: HSE.Name a -> (Fixity, String)-nameString (HSE.Ident _ s)  = (Pref, s)-nameString (HSE.Symbol _ s) = (Inf, s)--qnameString :: HSE.QName a -> (Fixity, String)-qnameString (HSE.Qual _ m n) = fmap ((HSE.prettyPrint m ++ ".") ++) (nameString n)-qnameString (HSE.UnQual _ n) = nameString n-qnameString (HSE.Special _ sc) = case sc of-  HSE.UnitCon _              -> (Pref, "()")-  HSE.ListCon _              -> (Pref, "[]")-  HSE.FunCon _               -> (Inf, "->")-  HSE.TupleCon _ HSE.Boxed n -> (Inf, replicate (n-1) ',')-  HSE.TupleCon{}             -> todo sc-  HSE.Cons _                 -> (Inf, ":")-  HSE.UnboxedSingleCon{}     -> todo sc-  HSE.ExprHole{}             -> todo sc--opString :: HSE.QOp a -> (Fixity, String)-opString (HSE.QVarOp _ qn) = qnameString qn-opString (HSE.QConOp _ qn) = qnameString qn--list :: [Expr] -> Expr-list = foldr (\y ys -> cons `App` y `App` ys) nil--hseToExpr :: HSE.Exp a -> Expr-hseToExpr expr = case expr of-  HSE.Var _ qn -> uncurry Var (qnameString qn)-  HSE.IPVar{} -> todo expr-  HSE.Con _ qn -> uncurry Var (qnameString qn)-  HSE.Lit _ l -> case l of-    HSE.String _ _ s -> list (map (Var Pref . show) s)-    _                -> Var Pref (HSE.prettyPrint l)-  HSE.InfixApp _ p op q -> apps (Var Inf (snd (opString op))) [p,q]-  HSE.App _ f x -> hseToExpr f `App` hseToExpr x-  HSE.NegApp _ e -> Var Pref "negate" `App` hseToExpr e-  HSE.Lambda _ ps e -> foldr (Lambda . hseToPattern) (hseToExpr e) ps-  HSE.Let _ bs e -> case bs of-    HSE.BDecls _ ds   -> Let (map hseToDecl ds) (hseToExpr e)-    HSE.IPBinds _ ips -> todo ips-  HSE.If _ b t f -> apps if' [b,t,f]-  HSE.Case{} -> todo expr-  HSE.Do{} -> todo expr-  HSE.MDo{} -> todo expr-  HSE.Tuple _ HSE.Boxed es -> apps (Var Inf (replicate (length es - 1) ','))  es-  HSE.TupleSection{} -> todo expr-  HSE.List _ xs -> list (map hseToExpr xs)-  HSE.Paren _ e -> hseToExpr e-  HSE.LeftSection _ l op -> Var Inf (snd (opString op)) `App` hseToExpr l-  HSE.RightSection _ op r -> flip' `App` Var Inf (snd (opString op)) `App` hseToExpr r-  HSE.RecConstr{} -> todo expr-  HSE.RecUpdate{} -> todo expr-  HSE.EnumFrom _ x -> apps (Var Pref "enumFrom") [x]-  HSE.EnumFromTo _ x y -> apps (Var Pref "enumFromTo") [x,y]-  HSE.EnumFromThen _ x y -> apps (Var Pref "enumFromThen") [x,y]-  HSE.EnumFromThenTo _ x y z -> apps (Var Pref "enumFromThenTo") [x,y,z]-  _ -> todo expr--apps :: Expr -> [HSE.Exp a] -> Expr-apps = foldl (\a x -> a `App` hseToExpr x)--hseToDecl :: HSE.Decl a -> Decl-hseToDecl dec = case dec of-  HSE.PatBind _ (HSE.PVar _ n) (HSE.UnGuardedRhs _ e) Nothing ->-    Define (snd (nameString n)) (hseToExpr e)-  HSE.FunBind _ [HSE.Match _ n ps (HSE.UnGuardedRhs _ e) Nothing] ->-    Define (snd (nameString n)) (foldr (\p x -> Lambda (hseToPattern p) x) (hseToExpr e) ps)-  _ -> todo dec--hseToPattern :: HSE.Pat a -> Pattern-hseToPattern pat = case pat of-  HSE.PVar _ n -> PVar (snd (nameString n))-  HSE.PInfixApp _ l (HSE.Special _ (HSE.Cons _)) r -> PCons (hseToPattern l) (hseToPattern r)-  HSE.PTuple _ HSE.Boxed [p,q] -> PTuple (hseToPattern p) (hseToPattern q)-  HSE.PParen _ p -> hseToPattern p-  HSE.PWildCard _ -> PVar "_"-  _ -> todo pat--parsePF :: String -> Either String TopLevel-parsePF inp = case HSE.parseExp inp of-  HSE.ParseOk e -> Right (TLE (hseToExpr e))-  HSE.ParseFailed _ _ -> case HSE.parseDecl inp of-    HSE.ParseOk d         -> Right (TLD True (hseToDecl d))-    HSE.ParseFailed _ err -> Left err

@@ -1,146 +0,0 @@-{-# LANGUAGE PatternGuards #-}-module Plugin.Pl.PrettyPrinter (-  prettyDecl,-  prettyExpr,-  prettyTopLevel,- ) where--import           Plugin.Pl.Common--import           Data.Char-import           Data.List        (intercalate)--prettyDecl :: Decl -> String-prettyDecl (Define f e) = f ++ " = " ++ prettyExpr e--prettyDecls :: [Decl] -> String-prettyDecls = intercalate "; " . map prettyDecl--prettyExpr :: Expr -> String-prettyExpr = show . toSExpr--prettyTopLevel :: TopLevel -> String-prettyTopLevel (TLE e)   = prettyExpr e-prettyTopLevel (TLD _ d) = prettyDecl d--data SExpr-  = SVar !String-  | SLambda ![Pattern] !SExpr-  | SLet ![Decl] !SExpr-  | SApp !SExpr !SExpr-  | SInfix !String !SExpr !SExpr-  | LeftSection !String !SExpr  -- (x +)-  | RightSection !String !SExpr -- (+ x)-  | List ![SExpr]-  | Tuple ![SExpr]-  | Enum !Expr !(Maybe Expr) !(Maybe Expr)--{-# INLINE toSExprHead #-}-toSExprHead :: String -> [Expr] -> Maybe SExpr-toSExprHead hd tl-  | all (==',') hd, length hd+1 == length tl-  = Just . Tuple . reverse $ map toSExpr tl-  | otherwise = case (hd,reverse tl) of-      ("enumFrom", [e])              -> Just $ Enum e Nothing   Nothing-      ("enumFromThen", [e,e'])       -> Just $ Enum e (Just e') Nothing-      ("enumFromTo", [e,e'])         -> Just $ Enum e Nothing   (Just e')-      ("enumFromThenTo", [e,e',e'']) -> Just $ Enum e (Just e') (Just e'')-      _                              -> Nothing--toSExpr :: Expr -> SExpr-toSExpr (Var _ v) = SVar v-toSExpr (Lambda v e) = case toSExpr e of-  (SLambda vs e') -> SLambda (v:vs) e'-  e'              -> SLambda [v] e'-toSExpr (Let ds e) = SLet ds $ toSExpr e-toSExpr e | Just (hd,tl) <- getHead e, Just se <- toSExprHead hd tl = se-toSExpr e | (ls, tl) <- getList e, tl == nil-  = List $ map toSExpr ls-toSExpr (App e1 e2) = case e1 of-  App (Var Inf v) e0-    -> SInfix v (toSExpr e0) (toSExpr e2)-  Var Inf v | v /= "-"-    -> LeftSection v (toSExpr e2)--  Var _ "flip" | Var Inf v <- e2, v == "-" -> toSExpr $ Var Pref "subtract"--  App (Var _ "flip") (Var pr v)-    | v == "-"  -> toSExpr $ Var Pref "subtract" `App` e2-    | v == "id" -> RightSection "$" (toSExpr e2)-    | Inf <- pr, any (/= ',') v -> RightSection v (toSExpr e2)-  _ -> SApp (toSExpr e1) (toSExpr e2)--getHead :: Expr -> Maybe (String, [Expr])-getHead (Var _ v)   = Just (v, [])-getHead (App e1 e2) = second (e2:) `fmap` getHead e1-getHead _           = Nothing--instance Show SExpr where-  showsPrec _ (SVar v) = (getPrefName v ++)-  showsPrec p (SLambda vs e) = showParen (p > minPrec) $ ('\\':) .-    foldr (.) id (intersperse (' ':) (map (prettyPrecPattern $ maxPrec+1) vs)) .-    (" -> "++) . showsPrec minPrec e-  showsPrec p (SApp e1 e2) = showParen (p > maxPrec) $-    showsPrec maxPrec e1 . (' ':) . showsPrec (maxPrec+1) e2-  showsPrec _ (LeftSection fx e) = showParen True $-    showsPrec (snd (lookupFix fx) + 1) e . (' ':) . (getInfName fx++)-  showsPrec _ (RightSection fx e) = showParen True $-    (getInfName fx++) . (' ':) . showsPrec (snd (lookupFix fx) + 1) e-  showsPrec _ (Tuple es) = showParen True-    (join `id` intersperse ", " (map show es) ++)--  showsPrec _ (List es)-    | Just cs <- mapM ((=<<) readM . fromSVar) es = shows (cs::String)-    | otherwise = ('[':) .-      (join `id` intersperse ", " (map show es) ++) . (']':)-    where fromSVar (SVar str) = Just str-          fromSVar _          = Nothing-  showsPrec _ (Enum fr tn to) = ('[':) . showString (prettyExpr fr) .-    showsMaybe (((',':) . prettyExpr) `fmap` tn) . (".."++) .-    showsMaybe (prettyExpr `fmap` to) . (']':)-      where showsMaybe = maybe id (++)-  showsPrec _ (SLet ds e) = ("let "++) . showString (prettyDecls ds ++ " in ") . shows e---  showsPrec p (SInfix fx e1 e2) = showParen (p > fixity) $-    showsPrec f1 e1 . (' ':) . (getInfName fx++) . (' ':) .-    showsPrec f2 e2 where-      fixity = snd $ lookupFix fx-      (f1, f2) = case fst $ lookupFix fx of-        AssocRight _ -> (fixity+1, fixity + infixSafe e2 (AssocLeft ()) fixity)-        AssocLeft _ -> (fixity + infixSafe e1 (AssocRight ()) fixity, fixity+1)-        AssocNone _ -> (fixity+1, fixity+1)--      -- This is a little bit awkward, but at least seems to produce no false-      -- results anymore-      infixSafe :: SExpr -> Assoc () -> Int -> Int-      infixSafe (SInfix fx'' _ _) assoc fx'-        | lookupFix fx'' == (assoc, fx') = 1-        | otherwise = 0-      infixSafe _ _ _ = 0 -- doesn't matter--prettyPrecPattern :: Int -> Pattern -> ShowS-prettyPrecPattern _ (PVar v) = showString v-prettyPrecPattern _ (PTuple p1 p2) = showParen True $-  prettyPrecPattern 0 p1 . (", "++) . prettyPrecPattern 0 p2-prettyPrecPattern p (PCons p1 p2) = showParen (p>5) $-  prettyPrecPattern 6 p1 . (':':) . prettyPrecPattern 5 p2--isOperator :: String -> Bool-isOperator s =-  case break (== '.') s of-    (_, "") -> isUnqualOp s-    (before, _dot : rest)-      | isUnqualOp before -> isUnqualOp rest-      | isModule before -> isOperator rest-      | otherwise -> False-  where-    isModule "" = False-    isModule (c : cs) = isUpper c && all (\c' -> isAlphaNum c' || c' `elem` ['\'', '_']) cs-    isUnqualOp s' = s' /= "()" && all (\c -> isSymbol c || isPunctuation c) s'--getInfName :: String -> String-getInfName str = if isOperator str then str else "`"++str++"`"--getPrefName :: String -> String-getPrefName str = if isOperator str || ',' `elem` str then "("++str++")" else str

@@ -1,875 +0,0 @@-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE PatternGuards             #-}-{-# LANGUAGE ScopedTypeVariables       #-}------ | This marvellous module contributed by Thomas J\344ger----module Plugin.Pl.Rules (RewriteRule(..), rules, fire) where--import           Plugin.Pl.Common--import           Data.Array-import qualified Data.Set          as S--import           Control.Monad.Fix (fix)----import PlModule.PrettyPrinter---- Next time I do somthing like this, I'll actually think about the combinator--- language before, instead of producing something ad-hoc like this:-data RewriteRule-  = RR Rewrite Rewrite-  | CRR (Expr -> Maybe Expr)-  | Down RewriteRule RewriteRule-  | Up RewriteRule RewriteRule-  | Or [RewriteRule]-  | OrElse RewriteRule RewriteRule-  | Then RewriteRule RewriteRule-  | Opt RewriteRule-  | If RewriteRule RewriteRule-  | Hard RewriteRule---- No MLambda here because we only consider closed Terms (no alpha-renaming!).-data MExpr-  = MApp !MExpr !MExpr-  | Hole !Int-  | Quote !Expr-  deriving Eq----instance Show MExpr where---  show = show . fromMExpr--data Rewrite = Rewrite {-  holes :: MExpr,-  rid   :: Int -- rlength - 1-} --deriving Show---- What are you gonna do when no recursive modules are possible?-class RewriteC a where-  getRewrite :: a -> Rewrite--instance RewriteC MExpr where-  getRewrite rule = Rewrite {-    holes   = rule,-    rid = 0-  }--type ExprArr = Array Int Expr--myFire :: ExprArr -> MExpr -> MExpr-myFire xs (MApp e1 e2) = MApp (myFire xs e1) (myFire xs e2)-myFire xs (Hole h)     = Quote $ xs ! h-myFire _ me            = me--nub' :: Ord a => [a] -> [a]-nub' = S.toList . S.fromList--uniqueArray :: Ord v => Int -> [(Int, v)] -> Maybe (Array Int v)-uniqueArray n lst-  | length (nub' lst) == n = Just $ array (0,n-1) lst-  | otherwise = Nothing--match :: Rewrite -> Expr -> Maybe ExprArr-match (Rewrite hl rid') e  = uniqueArray rid' =<< matchWith hl e--fire' :: Rewrite -> ExprArr -> MExpr-fire' (Rewrite hl _)   = (`myFire` hl)--fire :: Rewrite -> Rewrite -> Expr -> Maybe Expr-fire r1 r2 e = (fromMExpr . fire' r2) `fmap` match r1 e--matchWith :: MExpr -> Expr -> Maybe [(Int, Expr)]-matchWith (MApp e1 e2) (App e1' e2') =-  liftM2 (++) (matchWith e1 e1') (matchWith e2 e2')-matchWith (Quote e) e' = if e == e' then Just [] else Nothing-matchWith (Hole k) e = Just [(k,e)]-matchWith _ _ = Nothing--fromMExpr :: MExpr -> Expr-fromMExpr (MApp e1 e2) = App (fromMExpr e1) (fromMExpr e2)-fromMExpr (Hole _)     = Var Pref "Hole" -- error "Hole in MExpr"-fromMExpr (Quote e)    = e--instance RewriteC a => RewriteC (MExpr -> a) where-  getRewrite rule = Rewrite {-    holes = holes . getRewrite . rule . Hole $ pid,-    rid   = pid + 1-  } where-    pid = rid $ getRewrite (bt :: a)---- Yet another pointless transformation-transformM :: Int -> MExpr -> MExpr-transformM _ (Quote e) = constE `a` Quote e-transformM n (Hole n') = if n == n' then idE else constE `a` Hole n'-transformM n (Quote (Var _ ".") `MApp` e1 `MApp` e2)-  | e1 `hasHole` n && not (e2 `hasHole` n)-  = flipE `a` compE `a` e2 `c` transformM n e1-transformM n e@(MApp e1 e2)-  | fr1 && fr2 = sE `a` transformM n e1 `a` transformM n e2-  | fr1        = flipE `a` transformM n e1 `a` e2-  | fr2, Hole n' <- e2, n' == n = e1-  | fr2        = e1 `c` transformM n e2-  | otherwise  = constE `a` e-  where-    fr1 = e1 `hasHole` n-    fr2 = e2 `hasHole` n--hasHole :: MExpr -> Int -> Bool-hasHole (MApp e1 e2) n = e1 `hasHole` n || e2 `hasHole` n-hasHole (Quote _)   _  = False-hasHole (Hole n')   n  = n == n'------- haddock doesn't like n+k patterns, so rewrite them----getVariants, getVariants' :: Rewrite -> [Rewrite]-getVariants' r@(Rewrite _ 0)  = [r]-getVariants' r@(Rewrite e nk)-    | nk >= 1    = r : getVariants (Rewrite e' (nk-1))-    | otherwise  = error "getVariants' : nk went negative"-    where-        e' = decHoles $ transformM 0 e--        decHoles (Hole n')    = Hole (n'-1)-        decHoles (MApp e1 e2) = decHoles e1 `MApp` decHoles e2-        decHoles me           = me--getVariants = getVariants' -- r = trace (show vs) vs where vs = getVariants' r--rr, rr0, rr1, rr2 :: RewriteC a => a -> a -> RewriteRule--- use this rewrite rule and rewrite rules derived from it by iterated--- pointless transformation-rrList :: RewriteC a => a -> a -> [RewriteRule]-rrList r1 r2 = zipWith RR (getVariants r1') (getVariants r2') where-  r1' = getRewrite r1-  r2' = getRewrite r2--rr  r1 r2 = Or          $ rrList r1 r2-rr1 r1 r2 = Or . take 2 $ rrList r1 r2-rr2 r1 r2 = Or . take 3 $ rrList r1 r2---- use only this rewrite rule-rr0 r1 r2 = RR r1' r2' where-  r1' = getRewrite r1-  r2' = getRewrite r2--down, up :: RewriteRule -> RewriteRule-down = fix . Down-up   = fix . Up---idE, flipE, bindE, extE, returnE, consE, appendE, nilE, foldrE, foldlE, fstE,-  sndE, dollarE, constE, uncurryE, curryE, compE, headE, tailE, sE, commaE,-  fixE, foldl1E, notE, equalsE, nequalsE, plusE, multE, zeroE, oneE, lengthE,-  sumE, productE, concatE, concatMapE, joinE, mapE, fmapE, fmapIE, subtractE,-  minusE, liftME, apE, liftM2E, seqME, zipE, zipWithE, onE, oedipusE, comp2E,-  crossE, firstE, secondE, andE, orE, allE, anyE :: MExpr-idE        = Quote $ Var Pref "id"-flipE      = Quote $ Var Pref "flip"-constE     = Quote $ Var Pref "const"-compE      = Quote $ Var Inf "."-comp2E     = Quote $ Var Inf ".*"-comp3E     = Quote $ Var Inf ".**"-eyeE       = Quote $ Var Inf "-."-oedipusE   = Quote $ Var Inf "-.*"-oedipus2E  = Quote $ Var Inf "-.**"-onE        = Quote $ Var Pref "on"-ampersandE = Quote $ Var Inf "&"-sE         = Quote $ Var Pref "ap"-fixE       = Quote $ Var Pref "fix"-bindE      = Quote $ Var Inf  ">>="-extE       = Quote $ Var Inf  "=<<"-returnE    = Quote $ Var Pref "return"-consE      = Quote $ Var Inf  ":"-nilE       = Quote $ Var Pref "[]"-appendE    = Quote $ Var Inf  "++"-foldrE     = Quote $ Var Pref "foldr"-foldlE     = Quote $ Var Pref "foldl"-fstE       = Quote $ Var Pref "fst"-sndE       = Quote $ Var Pref "snd"-dollarE    = Quote $ Var Inf  "$"-uncurryE   = Quote $ Var Pref "uncurry"-curryE     = Quote $ Var Pref "curry"-headE      = Quote $ Var Pref "head"-tailE      = Quote $ Var Pref "tail"-commaE     = Quote $ Var Inf  ","-foldl1E    = Quote $ Var Pref "foldl1"-equalsE    = Quote $ Var Inf  "=="-nequalsE   = Quote $ Var Inf  "/="-notE       = Quote $ Var Pref "not"-plusE      = Quote $ Var Inf  "+"-multE      = Quote $ Var Inf  "*"-zeroE      = Quote $ Var Pref "0"-oneE       = Quote $ Var Pref "1"-lengthE    = Quote $ Var Pref "length"-sumE       = Quote $ Var Pref "sum"-productE   = Quote $ Var Pref "product"-concatE    = Quote $ Var Pref "concat"-concatMapE = Quote $ Var Pref "concatMap"-joinE      = Quote $ Var Pref "join"-mapE       = Quote $ Var Pref "map"-fmapE      = Quote $ Var Pref "fmap"-fmapIE     = Quote $ Var Inf  "fmap"-subtractE  = Quote $ Var Pref "subtract"-minusE     = Quote $ Var Inf  "-"-liftME     = Quote $ Var Pref "liftM"-liftM2E    = Quote $ Var Pref "liftM2"-fishE      = Quote $ Var Inf  ">=>"-kliesliE   = Quote $ Var Inf "<=<"-apE        = Quote $ Var Inf  "ap"-seqME      = Quote $ Var Inf  ">>"-zipE       = Quote $ Var Pref "zip"-zipWithE   = Quote $ Var Pref "zipWith"-crossE     = Quote $ Var Inf  "***"-firstE     = Quote $ Var Pref "first"-secondE    = Quote $ Var Pref "second"-andE       = Quote $ Var Pref "and"-orE        = Quote $ Var Pref "or"-allE       = Quote $ Var Pref "all"-anyE       = Quote $ Var Pref "any"-replaceE   = Quote $ Var Inf "<$"-pointyE    = Quote $ Var Inf "$>"----a, c, c2 :: MExpr -> MExpr -> MExpr-a       = MApp-c e1 e2 = compE `a` e1 `a` e2-c2 e1 e2 = comp2E `a` e1 `a` e2-c3 e1 e2 = comp3E `a` e1 `a` e2-o e1 e2 = oedipusE `a` e1 `a` e2-o2 e1 e2 = oedipus2E `a` e1 `a` e2-eye e1 e2 = eyeE `a` e1 `a` e2-infixl 9 `a`-infixr 8 `c`-infixr 8 `c2`-infixr 8 `o`---collapseLists :: Expr -> Maybe Expr-collapseLists (Var _ "++" `App` e1 `App` e2)-  | (xs,x) <- getList e1, x==nil,-    (ys,y) <- getList e2, y==nil = Just $ makeList $ xs ++ ys-collapseLists _ = Nothing--data Binary = forall a b c. (Read a, Show a, Read b, Show b, Read c, Show c) => BA (a -> b -> c)--evalBinary :: [(String, Binary)] -> Expr -> Maybe Expr-evalBinary fs (Var _ f' `App` Var _ x' `App` Var _ y')-  | Just (BA f) <- lookup f' fs = (Var Pref . show) `fmap` liftM2 f (readM x') (readM y')-evalBinary _ _ = Nothing--data Unary = forall a b. (Read a, Show a, Read b, Show b) => UA (a -> b)--evalUnary :: [(String, Unary)] -> Expr -> Maybe Expr-evalUnary fs (Var _ f' `App` Var _ x')-  | Just (UA f) <- lookup f' fs = (Var Pref . show . f) `fmap` readM x'-evalUnary _ _ = Nothing--assocR, assocL, assoc :: [String] -> Expr -> Maybe Expr--- (f `op` g) `op` h --> f `op` (g `op` h)-assocR ops (Var f1 op1 `App` (Var f2 op2 `App` e1 `App` e2) `App` e3)-  | op1 == op2 && op1 `elem` ops-  = Just (Var f1 op1 `App` e1 `App` (Var f2 op2 `App` e2 `App` e3))-assocR _ _ = Nothing---- f `op` (g `op` h) --> (f `op` g) `op` h-assocL ops (Var f1 op1 `App` e1 `App` (Var f2 op2 `App` e2 `App` e3))-  | op1 == op2 && op1 `elem` ops-  = Just (Var f1 op1 `App` (Var f2 op2 `App` e1 `App` e2) `App` e3)-assocL _ _ = Nothing---- op f . op g --> op (f `op` g)-assoc ops (Var _ "." `App` (Var f1 op1 `App` e1) `App` (Var f2 op2 `App` e2))-  | op1 == op2 && op1 `elem` ops-  = Just (Var f1 op1 `App` (Var f2 op2 `App` e1 `App` e2))-assoc _ _ = Nothing--commutative :: [String] -> Expr -> Maybe Expr-commutative ops (Var f op `App` e1 `App` e2)-  | op `elem` ops = Just (Var f op `App` e2 `App` e1)-commutative ops (Var _ "flip" `App` e@(Var _ op)) | op `elem` ops = Just e-commutative _ _ = Nothing---- TODO: Move rules into a file.-{-# INLINE simplifies #-}-simplifies :: RewriteRule-simplifies = Or [-  -- (f . g) x --> f (g x)-  rr0 (\f g x -> (f `c` g) `a` x)-      (\f g x -> f `a` (g `a` x)),-  -- (g -. f) -> f (g x)-  rr0 (\f g x -> (f `eye` g) `a` x)-      (\f g x -> f `a` (g `a` x)),-  -- (f .* g) x y -> f (g x y)-  rr0  (\f g x y -> (f `c2` g) `a` x `a` y)-       (\f g x y -> f `a` (g `a` x `a` y)),-  -- (f .** g) x y z -> f (g x y z)-  rr0 (\f g x y z -> (f `c3` g) `a` x `a` y `a` z)-      (\f g x y z -> f `a` (g `a` x `a` y `a` z)),-  -- (f -.* g) x y -> f x (g y)-  rr0  (\f g x y -> (f `o` g) `a` x `a` y)-       (\f g x y -> f `a` x `a` (g `a` y)),-  -- (f -.** g) -> f x y (g z)-  rr0 (\f g x y z -> (f `o2` g) `a` x `a` y `a` z)-      (\f g x y z -> f `a` x `a` y `a` (g `a` z)),-  -- x & f -> f x-  rr0 (\f x -> x `a` ampersandE `a` f)-      a,-  -- id x --> x-  rr0 (\x -> idE `a` x)-      id,-  -- flip (flip x) --> x-  rr  (\x -> flipE `a` (flipE `a` x))-      id,-  -- flip id x . f --> flip f x-  rr0 (\f x -> (flipE `a` idE `a` x) `c` f)-      (\f x -> flipE `a` f `a` x),-  -- id . f --> f-  rr0 (\f -> idE `c` f)-      id,-  -- f . id --> f-  rr0 (`c` idE)-      id,-  -- const x y --> x-  rr0 (\x y -> constE `a` x `a` y)-      const,-  -- not (not x) --> x-  rr  (\x -> notE `a` (notE `a` x))-      id,-  -- fst (x,y) --> x-  rr  (\x y -> fstE `a` (commaE `a` x `a` y))-      const,-  -- snd (x,y) --> y-  rr  (\x y -> sndE `a` (commaE `a` x `a` y))-      (\_ y -> y),-  -- head (x:xs) --> x-  rr  (\x xs -> headE `a` (consE `a` x `a` xs))-      const,-  -- tail (x:xs) --> xs-  rr  (\x xs -> tailE `a` (consE `a` x `a` xs))-      (\_ xs -> xs),-  -- uncurry f (x,y) --> f x y-  rr1 (\f x y -> uncurryE `a` f `a` (commaE `a` x `a` y))-      (\f x y -> f `a` x `a` y),-  -- uncurry (,) --> id-  rr  (uncurryE `a` commaE)-      idE,-  -- uncurry f . s (,) g --> s f g-  rr1 (\f g -> (uncurryE `a` f) `c` (sE `a` commaE `a` g))-      (\f g -> sE `a` f `a` g),-  -- curry fst --> const-  rr (curryE `a` fstE) constE,-  -- curry snd --> const id-  rr (curryE `a` sndE) (constE `a` idE),-  -- s f g x --> f x (g x)-  rr0 (\f g x -> sE `a` f `a` g `a` x)-      (\f g x -> f `a` x `a` (g `a` x)),-  -- flip f x y --> f y x-  rr0 (\f x y -> flipE `a` f `a` x `a` y)-      (\f x y -> f `a` y `a` x),-  -- flip (=<<) --> (>>=)-  rr0 (flipE `a` extE)-      bindE,--  -- TODO: Think about map/fmap-  -- fmap id --> id-  rr (fmapE `a` idE)-     idE,-  -- map id --> id-  rr (mapE `a` idE)-     idE,-  -- (f . g) . h --> f . (g . h)-  rr0 (\f g h -> (f `c` g) `c` h)-      (\f g h -> f `c` (g `c` h)),-  -- fmap f . fmap g -> fmap (f . g)-  rr0 (\f g -> fmapE `a` f `c` fmapE `a` g)-      (\f g -> fmapE `a` (f `c` g)),-  -- map f . map g -> map (f . g)-  rr0 (\f g -> mapE `a` f `c` mapE `a` g)-      (\f g -> mapE `a` (f `c` g))--  ]--onceRewrites :: RewriteRule-onceRewrites = Hard $ Or [-  -- ($) --> id-  rr0 dollarE-      idE,-  -- concatMap --> (=<<)-  rr concatMapE extE,-  -- concat    --> join-  rr concatE joinE,-  -- liftM --> fmap-  rr liftME fmapE,-  -- map --> fmap-  rr mapE fmapE,-  -- subtract -> flip (-)-  rr  subtractE-      (flipE `a` minusE)-  ]---- Now we can state rewrite rules in a nice high level way--- Rewrite rules should be as pointful as possible since the pointless variants--- will be derived automatically.-rules :: RewriteRule-rules = Or [-  -- f (g x) --> (f . g) x-  Hard $-  rr  (\f g x -> f `a` (g `a` x))-      (\f g x -> (f `c` g) `a` x),-  -- (>>=) --> flip (=<<)-  -- (>>=) --> flip (=<<)-  Hard $-  rr  bindE-      (flipE `a` extE),-  -- (.) id --> id-  rr (compE `a` idE)-     idE,-  -- (++) [x] --> (:) x-  rr  (\x -> appendE `a` (consE `a` x `a` nilE))-      (\x -> consE `a` x),-  -- (=<<) return --> id-  rr  (extE `a` returnE)-      idE,-  -- (=<<) f (return x) -> f x-  rr  (\f x -> extE `a` f `a` (returnE `a` x))-      a,-  -- (=<<) ((=<<) f . g) --> (=<<) f . (=<<) g-  rr  (\f g -> extE `a` ((extE `a` f) `c` g))-      (\f g -> (extE `a` f) `c` (extE `a` g)),-  -- flip (f . g) --> flip (.) g . flip f-  Hard $-  rr  (\f g -> flipE `a` (f `c` g))-      (\f g -> (flipE `a` compE `a` g) `c` (flipE `a` f)),-  -- flip (.) f . flip id --> flip f-  rr  (\f -> (flipE `a` compE `a` f) `c` (flipE `a` idE))-      (\f -> flipE `a` f),-  -- flip (.) f . flip flip --> flip (flip . f)-  rr  (\f -> (flipE `a` compE `a` f) `c` (flipE `a` flipE))-      (\f -> flipE `a` (flipE `c` f)),-  -- flip (flip (flip . f) g) --> flip (flip . flip f) g-  rr1 (\f g -> flipE `a` (flipE `a` (flipE `c` f) `a` g))-      (\f g -> flipE `a` (flipE `c` flipE `a` f) `a` g),--  -- flip (.) id --> id-  rr (flipE `a` compE `a` idE)-     idE,-  -- (.) . flip id --> flip flip-  rr  (compE `c` (flipE `a` idE))-      (flipE `a` flipE),-  -- s const x y --> y-  rr  (\x y -> sE `a` constE `a` x `a` y)-      (\_ y -> y),-  -- s (const . f) g --> f-  rr1 (\f g -> sE `a` (constE `c` f) `a` g)-      const,-  -- s (const f) --> (.) f-  rr  (\f -> sE `a` (constE `a` f))-      (\f -> compE `a` f),-  -- s (f . fst) snd --> uncurry f-  rr  (\f -> sE `a` (f `c` fstE) `a` sndE)-      (\f -> uncurryE `a` f),-  -- fst (join (,) x) --> x-  rr (\x -> fstE `a` (joinE `a` commaE `a` x))-     id,-  -- snd (join (,) x) --> x-  rr (\x -> sndE `a` (joinE `a` commaE `a` x))-     id,-  -- The next two are `simplifies', strictly speaking, but invoked rarely.-  -- uncurry f (x,y) --> f x y-  rr  (\f x y -> uncurryE `a` f `a` (commaE `a` x `a` y))-      (\f x y -> f `a` x `a` y),-  -- curry (uncurry f) --> f-  rr (\f -> curryE `a` (uncurryE `a` f))-     id,-  -- uncurry (curry f) --> f-  rr (\f -> uncurryE `a` (curryE `a` f))-     id,-  -- (const id . f) --> const id-  rr  (\f -> (constE `a` idE) `c` f)-      (\_ -> constE `a` idE),-  -- const x . f --> const x-  rr (\x f -> constE `a` x `c` f)-     (\x _ -> constE `a` x),-  -- fix f --> f (fix x)-  Hard $-  rr0 (\f -> fixE `a` f)-      (\f -> f `a` (fixE `a` f)),-  -- f (fix f) --> fix x-  Hard $-  rr0 (\f -> f `a` (fixE `a` f))-      (\f -> fixE `a` f),-  -- fix f --> f (f (fix x))-  Hard $-  rr0 (\f -> fixE `a` f)-      (\f -> f `a` (f `a` (fixE `a` f))),-  -- fix (const f) --> f-  rr (\f -> fixE `a` (constE `a` f))-     id,-  -- flip const x --> id-  rr  (\x -> flipE `a` constE `a` x)-      (pure idE),-  -- const . f --> flip (const f)-  Hard $-  rr  (\f -> constE `c` f)-      (\f -> flipE `a` (constE `a` f)),-  -- not (x == y) -> x /= y-  rr2 (\x y -> notE `a` (equalsE `a` x `a` y))-      (\x y -> nequalsE `a` x `a` y),-  -- not (x /= y) -> x == y-  rr2 (\x y -> notE `a` (nequalsE `a` x `a` y))-      (\x y -> equalsE `a` x `a` y),-  If (Or [rr plusE plusE, rr minusE minusE, rr multE multE]) $ down $ Or [-    -- 0 + x --> x-    rr  (\x -> plusE `a` zeroE `a` x)-        id,-    -- 0 * x --> 0-    rr  (\x -> multE `a` zeroE `a` x)-        (pure zeroE),-    -- 1 * x --> x-    rr  (\x -> multE `a` oneE `a` x)-        id,-    -- x - x --> 0-    rr  (\x -> minusE `a` x `a` x)-        (pure zeroE),-    -- x - y + y --> x-    rr  (\y x -> plusE `a` (minusE `a` x `a` y) `a` y)-        (\_ x -> x),-    -- x + y - y --> x-    rr  (\y x -> minusE `a` (plusE `a` x `a` y) `a` y)-        (\_ x -> x),-    -- x + (y - z) --> x + y - z-    rr  (\x y z -> plusE `a` x `a` (minusE `a` y `a` z))-        (\x y z -> minusE `a` (plusE `a` x `a` y) `a` z),-    -- x - (y + z) --> x - y - z-    rr  (\x y z -> minusE `a` x `a` (plusE `a` y `a` z))-        (\x y z -> minusE `a` (minusE `a` x `a` y) `a` z),-    -- x - (y - z) --> x + y - z-    rr  (\x y z -> minusE `a` x `a` (minusE `a` y `a` z))-        (\x y z -> minusE `a` (plusE `a` x `a` y) `a` z)-  ],--  -- flip ($) -> &-  rr (flipE `a` dollarE)-     ampersandE,--  -- fmap . const -> (<$)-  rr (fmapE `c` constE)-     replaceE,--  -- flip (<$) -> ($>)-  Hard $-  rr (flipE `a` replaceE)-     pointyE,--  Hard onceRewrites,-  -- join (fmap f x) --> f =<< x-  rr (\f x -> joinE `a` (fmapE `a` f `a` x))-     (\f x -> extE `a` f `a` x),-  -- (=<<) id --> join-  rr (extE `a` idE) joinE,-  -- join --> (=<<) id-  Hard $-  rr joinE (extE `a` idE),-  -- join (return x) --> x-  rr (\x -> joinE `a` (returnE `a` x))-     id,-  -- (return . f) =<< m --> fmap f m-  rr (\f m -> extE `a` (returnE `c` f) `a` m)-     (\f m -> fmapIE `a` f `a` m),-  -- (x >>=) . (return .) . f  --> flip (fmap . f) x-  rr (\f x -> bindE `a` x `c` (compE `a` returnE) `c` f)-     (\f x -> flipE `a` (fmapIE `c` f) `a` x),-  -- (>>=) (return f) --> flip id f-  rr (\f -> bindE `a` (returnE `a` f))-     (\f -> flipE `a` idE `a` f),-  -- liftM2 f x --> ap (f `fmap` x)-  Hard $-  rr (\f x -> liftM2E `a` f `a` x)-     (\f x -> apE `a` (fmapIE `a` f `a` x)),-  -- liftM2 f (return x) --> fmap (f x)-  rr (\f x -> liftM2E `a` f `a` (returnE `a` x))-     (\f x -> fmapIE `a` (f `a` x)),-  -- f `fmap` return x --> return (f x)-  rr (\f x -> fmapE `a` f `a` (returnE `a` x))-     (\f x -> returnE `a` (f `a` x)),-  -- (=<<) . flip (fmap . f) --> flip liftM2 f-  Hard $-  rr (\f -> extE `c` flipE `a` (fmapE `c` f))-     (\f -> flipE `a` liftM2E `a` f),--  -- ((f .) .) . g --> (f .** g)-  Hard $ rr (\f g -> (compE `a` (compE `a` f)) `c` g)-     (\f g -> (comp3E `a` f `a` g)),--  -- (f .) . g --> (f .* g)-  Hard $ rr (\f g -> (compE `a` f) `c` g)-     (\f g -> comp2E `a` f `a` g),--  -- flip (.) -> (-.)-  rr (flipE `a` compE)-     eyeE,--  -- (x &) -> ($ x)-  rr (\x -> ampersandE `a` x)-     (\x -> dollarE `a` x),--  -- f -.* (g . f) -> on g f-  Hard $-  rr (\f g -> oedipusE `a` f `a` (compE `a` g `a` f))-     (\f g -> onE `a` g `a` f),--  -- (.) -> fmap-  Hard $-  rr compE fmapE,--  -- join .* map x y -> (=<<) x y-  Hard $-  rr (joinE `c2` mapE) extE,--  -- map f (zip xs ys) --> zipWith (curry f) xs ys-  Hard $-  rr (\f xs ys -> mapE `a` f `a` (zipE `a` xs `a` ys))-     (\f xs ys -> zipWithE `a` (curryE `a` f) `a` xs `a` ys),--  -- zipWith (,) --> zip (,)-  rr (zipWithE `a` commaE) zipE,--  -- all f --> and . map f-  Hard $-  rr (\f -> allE `a` f)-     (\f -> andE `c` mapE `a` f),-  -- and . map f --> all f-  rr (\f -> andE `c` mapE `a` f)-     (\f -> allE `a` f),-  -- any f --> or . map f-  Hard $-  rr (\f -> anyE `a` f)-     (\f -> orE `c` mapE `a` f),-  -- or . map f --> any f-  rr (\f -> orE `c` mapE `a` f)-     (\f -> anyE `a` f),--  -- return f `ap` x --> fmap f x-  rr (\f x -> apE `a` (returnE `a` f) `a` x)-     (\f x -> fmapIE `a` f `a` x),-  -- ap (f `fmap` x) --> liftM2 f x-  rr (\f x -> apE `a` (fmapIE `a` f `a` x))-     (\f x -> liftM2E `a` f `a` x),-  -- f `ap` x --> (`fmap` x) =<< f-  Hard $-  rr (\f x -> apE `a` f `a` x)-     (\f x -> extE `a` (flipE `a` fmapIE `a` x) `a` f),-  -- (`fmap` x) =<< f --> f `ap` x-  rr (\f x -> extE `a` (flipE `a` fmapIE `a` x) `a` f)-     (\f x -> apE `a` f `a` x),-  -- (x >>=) . flip (fmap . f) -> liftM2 f x-  rr (\f x -> bindE `a` x `c` flipE `a` (fmapE `c` f))-     (\f x -> liftM2E `a` f `a` x),--  -- (f =<< m) x --> f (m x) x-  rr0 (\f m x -> extE `a` f `a` m `a` x)-      (\f m x -> f `a` (m `a` x) `a` x),-  -- (fmap f g x) --> f (g x)-  rr0 (\f g x -> fmapE `a` f `a` g `a` x)-      (\f g x -> f `a` (g `a` x)),-  -- return x y --> y-  rr  (\y x -> returnE `a` x `a` y)-      const,-  -- liftM2 f g h x --> g x `h` h x-  rr0 (\f g h x -> liftM2E `a` f `a` g `a` h `a` x)-      (\f g h x -> f `a` (g `a` x) `a` (h `a` x)),-  -- ap f id --> join f-  rr  (\f -> apE `a` f `a` idE)-      (\f -> joinE `a` f),--  -- flip flip f . ((.) .* g) --> f -.** g-  Hard $-  rr (\f g -> (flipE `a` flipE `a` f `c` (compE `c2` g)))-     (\f g -> oedipus2E `a` f `a` g),--  -- (. f) . g --> (f -.* g)-  Hard $-  rr (\f g -> (flipE `a` compE `a` f) `c` g)-     (\f g -> oedipusE `a` f `a` g),--  -- (=<<) const q --> flip (>>) q-  Hard $ -- ??-  rr (\q p -> extE `a` (constE `a` q) `a` p)-     (\q p -> seqME `a` p `a` q),-  -- p >> q --> const q =<< p-  Hard $-  rr (\p q -> seqME `a` p `a` q)-     (\p q -> extE `a` (constE `a` q) `a` p),--  -- ap (f -.* ((,) . f . fst)) snd --> f (***) f-  Hard $-  rr (\f -> apE `a` (f `o` (commaE `c` f `c` fstE)) `a` sndE)-     (\f -> joinE `a` crossE `a` f),--  -- flip (=<<) --> >>=-  rr (flipE `a` extE)-     bindE,--  -- flip (>=>) --> <=<-  rr (flipE `a` fishE)-     kliesliE,--  -- (.) . (=<<) --> <=<-  rr (compE `c` extE)-     kliesliE,--  -- join . (g .* f) --> f >=> g-  Hard $-    rr (\f g -> joinE `c` (g `c2` f))-       (\f g -> fishE `a` f `a` g),--  -- (`ap` snd) . (fst -.* (flip =<< (.) .* ((,) .))) --> join (***)-  -- Hard $-  rr ((flipE `a` apE `a` sndE) `c` (fstE `o` (extE `a` flipE `a` (compE `c2` (compE `a` commaE)))))-     (joinE `a` crossE),--  -- experimental support for Control.Arrow stuff-  -- (costs quite a bit of performace)-  -- uncurry ((. g) . (,) . f) --> f *** g-  rr (\f g -> uncurryE `a` ((flipE `a` compE `a` g) `c` commaE `c` f))-     (\f g -> crossE `a` f `a` g),-  -- uncurry ((,) . f) --> first f-  rr (\f -> uncurryE `a` (commaE `c` f))-     (\f -> firstE `a` f),-  -- uncurry ((. g) . (,)) --> second g-  rr (\g -> uncurryE `a` ((flipE `a` compE `a` g) `c` commaE))-     (\g -> secondE `a` g),-  -- I think we need all three of them:-  -- uncurry (const f) --> f . snd-  rr (\f -> uncurryE `a` (constE `a` f))-     (`c` sndE),-  -- uncurry const --> fst-  rr (uncurryE `a` constE)-     fstE,-  -- uncurry (const . f) --> f . fst-  rr (\f -> uncurryE `a` (constE `c` f))-     (`c` fstE),--  -- TODO is this the right place?-  -- [x] --> return x-  Hard $-  rr (\x -> consE `a` x `a` nilE)-     (\x -> returnE `a` x),-  -- list destructors-  Hard $-  If (Or [rr consE consE, rr nilE nilE]) $ Or [-    down $ Or [-      -- length [] --> 0-      rr (lengthE `a` nilE)-         zeroE,-      -- length (x:xs) --> 1 + length xs-      rr (\x xs -> lengthE `a` (consE `a` x `a` xs))-         (\_ xs -> plusE `a` oneE `a` (lengthE `a` xs))-    ],-    -- map/fmap elimination-    down $ Or [-      -- map f (x:xs) --> f x: map f xs-      rr (\f x xs -> mapE `a` f `a` (consE `a` x `a` xs))-         (\f x xs -> consE `a` (f `a` x) `a` (mapE `a` f `a` xs)),-      -- fmap f (x:xs) --> f x: Fmap f xs-      rr (\f x xs -> fmapE `a` f `a` (consE `a` x `a` xs))-         (\f x xs -> consE `a` (f `a` x) `a` (fmapE `a` f `a` xs)),-      -- map f []     --> []-      rr (\f -> mapE `a` f `a` nilE)-         (pure nilE),-      -- fmap f []     --> []-      rr (\f -> fmapE `a` f `a` nilE)-         (pure nilE)-    ],-    -- foldr elimination-    down $ Or [-      -- foldr f z (x:xs) --> f x (foldr f z xs)-      rr (\f x xs z -> (foldrE `a` f `a` z) `a` (consE `a` x `a` xs))-         (\f x xs z -> (f `a` x) `a` (foldrE `a` f `a` z `a` xs)),-      -- foldr f z [] --> z-      rr (\f z -> foldrE `a` f `a` z `a` nilE)-         (\_ z -> z)-    ],-    -- foldl elimination-    down $ Opt (CRR $ assocL ["."]) `Then` Or [-      -- sum xs --> foldl (+) 0 xs-      rr (\xs -> sumE `a` xs)-         (\xs -> foldlE `a` plusE `a` zeroE `a` xs),-      -- product xs --> foldl (*) 1 xs-      rr (\xs -> productE `a` xs)-         (\xs -> foldlE `a` multE `a` oneE `a` xs),-      -- foldl1 f (x:xs) --> foldl f x xs-      rr (\f x xs -> foldl1E `a` f `a` (consE `a` x `a` xs))-         (\f x xs -> foldlE `a` f `a` x `a` xs),-      -- foldl f z (x:xs) --> foldl f (f z x) xs-      rr (\f z x xs -> (foldlE `a` f `a` z) `a` (consE `a` x `a` xs))-         (\f z x xs -> foldlE `a` f `a` (f `a` z `a` x) `a` xs),-      -- foldl f z [] --> z-      rr (\f z -> foldlE `a` f `a` z `a` nilE)-         (\_ z -> z),-      -- special rule:-      -- foldl f z [x] --> f z x-      rr (\f z x -> foldlE `a` f `a` z `a` (returnE `a` x))-         (\f z x -> f `a` z `a` x),-      rr (\f z x -> foldlE `a` f `a` z `a` (consE `a` x `a` nilE))-         (\f z x -> f `a` z `a` x)-    ] `OrElse` (-      -- (:) x --> (++) [x]-      Opt (rr0 (\x -> consE `a` x)-         (\x -> appendE `a` (consE `a` x `a` nilE))) `Then`-      -- More special rule: (:) x . (++) ys --> (++) (x:ys)-      up (rr0 (\x ys -> (consE `a` x) `c` (appendE `a` ys))-         (\x ys -> appendE `a` (consE `a` x `a` ys)))-      )-  ],--  -- Complicated Transformations-  CRR collapseLists,-  up $ Or [CRR (evalUnary unaryBuiltins), CRR (evalBinary binaryBuiltins)],-  up $ CRR (assoc assocOps),-  up $ CRR (assocL assocOps),-  up $ CRR (assocR assocOps),-  Up (CRR (commutative commutativeOps)) $ down $ Or [CRR $ assocL assocLOps,-                                                     CRR $ assocR assocROps],--  Hard simplifies-  ] `Then` Opt (up simplifies)-assocLOps, assocROps, assocOps :: [String]-assocLOps = ["+", "*", "&&", "||", "max", "min"]-assocROps = [".", "++", ".*", ".**"]-assocOps  = assocLOps ++ assocROps--commutativeOps :: [String]-commutativeOps = ["*", "+", "==", "/=", "max", "min"]--unaryBuiltins :: [(String,Unary)]-unaryBuiltins = [-    ("not",    UA (not    :: Bool -> Bool)),-    ("negate", UA (negate :: Integer -> Integer)),-    ("signum", UA (signum :: Integer -> Integer)),-    ("abs",    UA (abs    :: Integer -> Integer))-  ]--binaryBuiltins :: [(String,Binary)]-binaryBuiltins = [-    ("+",    BA ((+)  :: Integer -> Integer -> Integer)),-    ("-",    BA ((-)  :: Integer -> Integer -> Integer)),-    ("*",    BA ((*)  :: Integer -> Integer -> Integer)),-    ("^",    BA ((^)  :: Integer -> Integer -> Integer)),-    ("<",    BA ((<)  :: Integer -> Integer -> Bool)),-    (">",    BA ((>)  :: Integer -> Integer -> Bool)),-    ("==",   BA ((==) :: Integer -> Integer -> Bool)),-    ("/=",   BA ((/=) :: Integer -> Integer -> Bool)),-    ("<=",   BA ((<=) :: Integer -> Integer -> Bool)),-    (">=",   BA ((>=) :: Integer -> Integer -> Bool)),-    ("div",  BA (div  :: Integer -> Integer -> Integer)),-    ("mod",  BA (mod  :: Integer -> Integer -> Integer)),-    ("max",  BA (max  :: Integer -> Integer -> Integer)),-    ("min",  BA (min  :: Integer -> Integer -> Integer)),-    ("&&",   BA ((&&) :: Bool -> Bool -> Bool)),-    ("||",   BA ((||) :: Bool -> Bool -> Bool))-  ]

@@ -1,146 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PatternGuards     #-}-module Plugin.Pl.Transform (-    transform,-  ) where--import           Control.Monad.Trans.State-import           Data.Graph                (flattenSCC, flattenSCCs,-                                            stronglyConnComp)-import qualified Data.Map                  as M-import           Data.Maybe-import           Plugin.Pl.Common--occursP :: String -> Pattern -> Bool-occursP v (PVar v')      = v == v'-occursP v (PTuple p1 p2) = v `occursP` p1 || v `occursP` p2-occursP v (PCons  p1 p2) = v `occursP` p1 || v `occursP` p2--freeIn :: String -> Expr -> Int-freeIn v (Var _ v') = fromEnum $ v == v'-freeIn v (Lambda pat e) = if v `occursP` pat then 0 else freeIn v e-freeIn v (App e1 e2) = freeIn v e1 + freeIn v e2-freeIn v (Let ds e') = if v `elem` map declName ds then 0-  else freeIn v e' + sum [freeIn v e | Define _ e <- ds]--isFreeIn :: String -> Expr -> Bool-isFreeIn v e = freeIn v e > 0--tuple :: [Expr] -> Expr-tuple  = foldr1 (\x y -> Var Inf "," `App` x `App` y)--tupleP :: [String] -> Pattern-tupleP vs = foldr1 PTuple $ PVar `map` vs--dependsOn :: [Decl] -> Decl -> [Decl]-dependsOn ds d = [d' | d' <- ds, declName d' `isFreeIn` declExpr d]--unLet :: Expr -> Expr-unLet (App e1 e2) = App (unLet e1) (unLet e2)-unLet (Let [] e) = unLet e-unLet (Let ds e) = unLet $-  Lambda (tupleP $ declName `map` dsYes) (Let dsNo e) `App`-    (fix' `App` Lambda (tupleP $ declName `map` dsYes)-                        (tuple  $ declExpr `map` dsYes))-    where-  comps = stronglyConnComp [(d',d',dependsOn ds d') | d' <- ds]-  dsYes = flattenSCC $ head comps-  dsNo = flattenSCCs $ tail comps--unLet (Lambda v e) = Lambda v (unLet e)-unLet (Var f x) = Var f x--type Env = M.Map String String---- It's a pity we still need that for the pointless transformation.--- Otherwise a newly created id/const/... could be bound by a lambda--- e.g. transform' (\id x -> x) ==> transform' (\id -> id) ==> id-alphaRename :: Expr -> Expr-alphaRename e = alpha e `evalState` M.empty where-  alpha :: Expr -> State Env Expr-  alpha (Var f v)     = Var f . fromMaybe v . M.lookup v <$> get-  alpha (App e1 e2)   = liftM2 App (alpha e1) (alpha e2)-  alpha (Let _ _)     = assert False bt-  alpha (Lambda v e') = inEnv $ liftM2 Lambda (alphaPat v) (alpha e')--  -- act like a reader monad-  inEnv :: State s a -> State s a-  inEnv f = gets $ evalState f--  alphaPat (PVar v) = do-    fm <- get-    let v' = "$" ++ show (M.size fm)-    put $ M.insert v v' fm-    return $ PVar v'-  alphaPat (PTuple p1 p2) = liftM2 PTuple (alphaPat p1) (alphaPat p2)-  alphaPat (PCons p1 p2) = liftM2 PCons (alphaPat p1) (alphaPat p2)---transform :: Expr -> Expr-transform = transform' . alphaRename . unLet---- Infinite generator of variable names.-varNames :: [String]-varNames = flip replicateM usableChars =<< [1..]-  where-    usableChars = ['a'..'z']---- First variable name not already in use-fresh :: [String] -> String-fresh variables = head . filter (not . flip elem variables) $ varNames--names :: Expr -> [String]-names (Var _ str)     = [str]--- Lambda pattern names are rewritten to be meaningless/unwritable, so we don't--- need to include them here. Variables from lambdas used in expressions are--- also rewritten, but there's no reason to special-case it unless it's provably--- poor-performing to scan over the result in `fresh`, which I doubt it is.-names (Lambda _ exp') = names exp'-names (App exp1 exp2) = names exp1 ++ names exp2-names (Let dlcs exp') = (dnames =<< dlcs) ++ names exp'-  where-    dnames (Define nm exp'') = nm : names exp''--transform' :: Expr -> Expr-transform' exp' = go exp'-  where-    -- Explicit sharing for readability-    vars = names exp'--    go Let {} =-      assert False bt-    go (Var f v) =-      Var f v-    go (App e1 e2) =-      App (go e1) (go e2)-    go (Lambda (PTuple p1 p2) e) =-      go $-        Lambda (PVar var) $ (Lambda p1 . Lambda p2 $ e) `App` f `App` s-      where-        var   = fresh vars-        f     = Var Pref "fst" `App` Var Pref var-        s     = Var Pref "snd" `App` Var Pref var-    go (Lambda (PCons p1 p2) e) =-      go $-        Lambda (PVar var) $ (Lambda p1 . Lambda p2 $ e) `App` f `App` s-      where-        var = fresh vars-        f   = Var Pref "head" `App` Var Pref var-        s   = Var Pref "tail" `App` Var Pref var-    go (Lambda (PVar v) e) =-      go $ getRidOfV e-      where-        getRidOfV (Var f v') | v == v'   = id'-                             | otherwise = const' `App` Var f v'-        getRidOfV l@(Lambda pat _) =-          assert (not $ v `occursP` pat) $ getRidOfV $ go l-        getRidOfV Let {} = assert False bt-        getRidOfV e'@(App e1 e2)-          | fr1 && fr2 = scomb `App` getRidOfV e1 `App` getRidOfV e2-          | fr1 = flip' `App` getRidOfV e1 `App` e2-          | Var _ v' <- e2, v' == v = e1-          | fr2 = comp `App` e1 `App` getRidOfV e2-          | otherwise = const' `App` e'-          where-            fr1 = v `isFreeIn` e1-            fr2 = v `isFreeIn` e2

@@ -1,31 +0,0 @@-module Pointfree where--import Plugin.Pl.Common (mapTopLevel, mapTopLevel')-import Plugin.Pl.Optimize (optimize)-import Plugin.Pl.Parser (parsePF)-import Plugin.Pl.PrettyPrinter (prettyTopLevel)-import Plugin.Pl.Transform (transform)--import Data.Maybe (listToMaybe)--{- |-  >>> pointfree "I'm not a valid Haskell expression!"-  []-  >>> pointfree "sum xs = foldr (+) 0 xs"-  ["sum = id (fix (const (foldr (+) 0)))","sum = fix (const (foldr (+) 0))","sum = foldr (+) 0"]--}-pointfree :: String -> [String]-pointfree-  = either-    (const [])-    (map prettyTopLevel . mapTopLevel' optimize . mapTopLevel transform)-  . parsePF--{- |-  >>> pointfree' "I'm not a valid Haskell expression!"-  Nothing-  >>> pointfree' "sum xs = foldr (+) 0 xs"-  Just "sum = foldr (+) 0"--}-pointfree' :: String -> Maybe String-pointfree' = listToMaybe . reverse . pointfree

@@ -0,0 +1,30 @@+module Pointfree where++import           Data.Maybe              (listToMaybe)+import           Plugin.Pl.Common        (mapTopLevel, mapTopLevel')+import           Plugin.Pl.Optimize      (optimize)+import           Plugin.Pl.Parser        (parsePF)+import           Plugin.Pl.PrettyPrinter (prettyTopLevel)+import           Plugin.Pl.Transform     (transform)++{- |+  >>> pointfree "I'm not a valid Haskell expression!"+  []+  >>> pointfree "sum xs = foldr (+) 0 xs"+  ["sum = id (fix (const (foldr (+) 0)))","sum = fix (const (foldr (+) 0))","sum = foldr (+) 0"]+-}+pointfree :: String -> [String]+pointfree+  = either+    (pure [])+    (map prettyTopLevel . mapTopLevel' optimize . mapTopLevel transform)+  . parsePF++{- |+  >>> pointfree' "I'm not a valid Haskell expression!"+  Nothing+  >>> pointfree' "sum xs = foldr (+) 0 xs"+  Just "sum = foldr (+) 0"+-}+pointfree' :: String -> Maybe String+pointfree' = listToMaybe . reverse . pointfree

@@ -1,11 +1,12 @@-cabal-version: >=1.8+cabal-version: 2.0 name: pointfree-fancy-version: 1.1.1.7+version: 1.1.1.8 license: BSD3 license-file: LICENSE maintainer: Vanessa McHale <vamchale@gmail.com> author: Thomas Jäger-tested-with: ghc ==8.0.1 ghc ==8.2.2 ghc ==8.4.1 ghc ==7.10.3+tested-with: ghc ==8.0.2 ghc ==8.2.2 ghc ==8.4.3 ghc ==7.10.3+             ghc ==8.6.1 synopsis: Tool for refactoring expressions into pointfree form description:     The pointfree tool is a standalone command-line version of the pl@@ -23,55 +24,49 @@ library     exposed-modules:         Pointfree-    other-modules:+    hs-source-dirs: lib+    default-language: Haskell98+    ghc-options: -Wall+    build-depends:+        base -any,+        pointfree-internal -any++library pointfree-internal+    exposed-modules:         Plugin.Pl.Common         Plugin.Pl.Parser         Plugin.Pl.PrettyPrinter         Plugin.Pl.Optimize         Plugin.Pl.Rules         Plugin.Pl.Transform+    hs-source-dirs: src+    default-language: Haskell98+    other-extensions: FlexibleInstances PatternGuards ImplicitParams+                      ExistentialQuantification FlexibleInstances ScopedTypeVariables     ghc-options: -Wall     build-depends:-        base >=4.5 && <5.0,+        base >=4.8 && <5.0,         array >=0.3 && <0.6,-        containers >=0.4 && <0.6,+        containers >=0.4 && <0.7,         haskell-src-exts >=1.18 && <1.21,         transformers <0.6  executable pointfree     main-is: Main.hs-    other-modules:-        Plugin.Pl.Common-        Plugin.Pl.Parser-        Plugin.Pl.PrettyPrinter-        Plugin.Pl.Optimize-        Plugin.Pl.Rules-        Plugin.Pl.Transform+    default-language: Haskell98     ghc-options: -Wall     build-depends:         base >=4.3 && <5.0,-        array >=0.3 && <0.6,-        containers >=0.4 && <0.6,-        haskell-src-exts >=1.18 && <1.21,-        transformers <0.6+        pointfree-internal -any  test-suite tests     type: exitcode-stdio-1.0     main-is: Test.hs     hs-source-dirs: . test-    other-modules:-        Plugin.Pl.Common-        Plugin.Pl.Parser-        Plugin.Pl.PrettyPrinter-        Plugin.Pl.Optimize-        Plugin.Pl.Rules-        Plugin.Pl.Transform+    default-language: Haskell98     ghc-options: -Wall     build-depends:-        array >=0.3 && <0.6,         base <5,-        containers >=0.3 && <0.6,-        haskell-src-exts >=1.18 && <1.21,+        pointfree-internal -any,         HUnit >=1.1 && <1.7,-        QuickCheck >=2.1 && <2.11,-        transformers <0.6+        QuickCheck >=2.1 && <2.11

@@ -0,0 +1,130 @@+module Plugin.Pl.Common (+        Fixity(..), Expr(..), Pattern(..), Decl(..), TopLevel(..),+        bt, mapTopLevel, mapTopLevel',+        lookupFix, minPrec, maxPrec,+        comp, flip', id', const', scomb, cons, nil, fix', if', readM,+        makeList, getList,+        Assoc(..),+        module Data.Maybe,+        module Control.Arrow,+        module Data.List,+        module Control.Monad,+        module GHC.Base+    ) where++import           Control.Arrow         (first, second, (&&&), (***), (+++),+                                        (|||))+import           Control.Monad+import           Data.List             (intersperse, minimumBy)+import qualified Data.Map              as M+import           Data.Maybe            (fromJust, fromMaybe, isJust)+import           GHC.Base              (assert)+import           Language.Haskell.Exts (Assoc (..))+++-- The rewrite rules can be found at the end of the file Rules.hs++-- Not sure if passing the information if it was used as infix or prefix+-- is worth threading through the whole thing is worth the effort,+-- but it stays that way until the prettyprinting algorithm gets more+-- sophisticated.+data Fixity = Pref | Inf deriving Show++instance Eq Fixity where+  _ == _ = True++instance Ord Fixity where+  compare _ _ = EQ++data Expr+  = Var Fixity String+  | Lambda Pattern Expr+  | App Expr Expr+  | Let [Decl] Expr+  deriving (Eq, Ord, Show)++data Pattern+  = PVar String+  | PCons Pattern Pattern+  | PTuple Pattern Pattern+  deriving (Eq, Ord, Show)++data Decl = Define {+  declName :: String,+  declExpr :: Expr+} deriving (Eq, Ord, Show)++data TopLevel = TLD Bool Decl | TLE Expr deriving (Eq, Ord, Show)++mapTopLevel :: (Expr -> Expr) -> TopLevel -> TopLevel+mapTopLevel f tl = case getExpr tl of (e, c) -> c $ f e++mapTopLevel' :: Functor f => (Expr -> f Expr) -> TopLevel -> f TopLevel+mapTopLevel' f tl = case getExpr tl of (e, c) -> c <$> f e++getExpr :: TopLevel -> (Expr, Expr -> TopLevel)+getExpr (TLD True (Define foo e)) = (Let [Define foo e] (Var Pref foo),+                                     TLD False . Define foo)+getExpr (TLD False (Define foo e)) = (e, TLD False . Define foo)+getExpr (TLE e)      = (e, TLE)++comp, flip', id', const', scomb, cons, nil, fix', if' :: Expr+comp   = Var Inf  "."+flip'  = Var Pref "flip"+id'    = Var Pref "id"+const' = Var Pref "const"+scomb  = Var Pref "ap"+cons   = Var Inf  ":"+nil    = Var Pref "[]"+fix'   = Var Pref "fix"+if'    = Var Pref "if'"++makeList :: [Expr] -> Expr+makeList = foldr (\e1 e2 -> cons `App` e1 `App` e2) nil++-- Modularity is a drag+getList :: Expr -> ([Expr], Expr)+getList (c `App` x `App` tl) | c == cons = first (x:) $ getList tl+getList e                    = ([],e)++bt :: a+bt = undefined++shift, minPrec, maxPrec :: Int+shift = 0+maxPrec = shift + 10+minPrec = 0++-- operator precedences are needed both for parsing and prettyprinting+operators :: [[(String, (Assoc (), Int))]]+operators = (map . map . second . second $ (+shift))+  [[inf "." (AssocRight ()) 9, inf "!!" (AssocLeft ()) 9],+   [inf name (AssocRight ()) 8 | name <- ["^", "^^", "**"]],+   [inf name (AssocLeft ()) 7+     | name <- ["*", "/", "`quot`", "`rem`", "`div`", "`mod`", ":%", "%"]],+   [inf name (AssocLeft ()) 6  | name <- ["+", "-"]],+   [inf name (AssocRight ()) 5 | name <- [":", "++"]],+   [inf name (AssocNone ()) 4+     | name <- ["==", "/=", "<", "<=", ">=", ">", "`elem`", "`notElem`"]],+   [inf "&&" (AssocRight ()) 3],+   [inf "||" (AssocRight ()) 2],+   [inf ">>" (AssocLeft ()) 1, inf ">>=" (AssocLeft ()) 1, inf "=<<" (AssocRight ()) 1],+   [inf name (AssocRight ()) 0 | name <- ["$", "$!", "`seq`"]]+  ] where+  inf name assoc fx = (name, (assoc, fx))++opFM :: M.Map String (Assoc (), Int)+opFM = M.fromList $ join operators++lookupOp :: String -> Maybe (Assoc (), Int)+lookupOp k = M.lookup k opFM++lookupFix :: String -> (Assoc (), Int)+lookupFix str = fromMaybe (AssocLeft (), 9 + shift) (lookupOp str)++readM :: (Monad m, Read a) => String -> m a+readM s = case [x | (x,t) <- reads s, ("","")  <- lex t] of+            [x] -> return x+            []  -> fail "readM: No parse."+            _   -> fail "readM: Ambiguous parse."+

@@ -0,0 +1,102 @@+{-# LANGUAGE ImplicitParams #-}+module Plugin.Pl.Optimize (+    optimize,+  ) where++import           Plugin.Pl.Common+import           Plugin.Pl.PrettyPrinter (prettyExpr)+import           Plugin.Pl.Rules++import           Data.List               (nub)++cut :: [a] -> [a]+cut = take 1++toMonadPlus :: MonadPlus m => Maybe a -> m a+toMonadPlus Nothing  = mzero+toMonadPlus (Just x)=return x++type Size = Integer+-- This seems to be a better size for our purposes,+-- despite being "a little" slower because of the wasteful uglyprinting+sizeExpr' :: Expr -> Size+sizeExpr' e = 100 * fromIntegral (length $ prettyExpr e) + adjust e where+  -- hackish thing to favor some expressions if the length is the same:+  -- (+ x) --> (x +)+  -- x >>= f --> f =<< x+  -- f $ g x --> f (g x)+  adjust :: Expr -> Size+  adjust (Var _ str) -- Just n <- readM str = log (n*n+1) / 4+                     | str == "uncurry"    = -400+--                     | str == "s"          = 500+                     | str == "flip"       = 10+                     | str == ">>="        = 5+                     | str == "$"          = 1+                     | str == "subtract"   = 1+                     | str == "ap"         = 200+                     | str == "liftM2"     = 101+                     | str == "return"     = -200+                     | str == "zipWith"    = -400+                     | str == "const"      = 0 -- -200+                     | str == "fmap"       = -100+  adjust (Lambda _ e') = adjust e'+  adjust (App e1 e2)  = adjust e1 + adjust e2+  adjust _ = 0++optimize :: Expr -> [Expr]+optimize e = result where+  result :: [Expr]+  result = map (snd . fromJust) . takeWhile isJust .+    iterate ((=<<) simpleStep) $ Just (sizeExpr' e, e)++  simpleStep :: (Size, Expr) -> Maybe (Size, Expr)+  simpleStep t = do+    let chn = let ?first = True in step (snd t)+        chnn = let ?first = False in step =<< chn+        new = filter (\(x,_) -> x < fst t) . map (sizeExpr' &&& id) $+                snd t: chn ++ chnn+    case new of+      []       -> Nothing+      (new':_) -> return new'++step :: (?first :: Bool) => Expr -> [Expr]+step e = nub $ rewrite rules e++rewrite :: (?first :: Bool) => RewriteRule -> Expr -> [Expr]+rewrite rl e = case rl of+    Up r1 r2     -> let e'  = cut $ rewrite r1 e+                        e'' = rewrite r2 =<< e'+                    in if null e'' then e' else e''+    OrElse r1 r2 -> let e'  = rewrite r1 e+                    in if null e' then rewrite r2 e else e'+    Then r1 r2   -> rewrite r2 =<< nub (rewrite r1 e)+    Opt  r       -> e: rewrite r e+    If   p  r    -> if null (rewrite p e) then mzero else rewrite r e+    Hard r       -> if ?first then rewrite r e else mzero+    Or rs        -> (`rewrite` e) =<< rs+    RR {}        -> rewDeep rl e+    CRR {}       -> rewDeep rl e+    Down {}      -> rewDeep rl e++rewDeep :: (?first :: Bool) => RewriteRule -> Expr -> [Expr]+rewDeep rule e = rew rule e `mplus` case e of+    Var _ _    -> mzero+    Lambda _ _ -> error "lambda: optimizer only works for closed expressions"+    Let _ _    -> error "let: optimizer only works for closed expressions"+    App e1 e2  -> ((`App` e2) `map` rewDeep rule e1) `mplus`+                  ((e1 `App`) `map` rewDeep rule e2)++rew :: (?first :: Bool) => RewriteRule -> Expr -> [Expr]+rew (RR r1 r2) e = toMonadPlus $ fire r1 r2 e+rew (CRR r) e = toMonadPlus $ r e+rew (Or rs) e = (`rew` e) =<< rs+rew (Down r1 r2) e+  = if null e'' then e' else e'' where+    e'  = cut $ rew r1 e+    e'' = rewDeep r2 =<< e'+rew r@Then   {} e = rewrite r e+rew r@OrElse {} e = rewrite r e+rew r@Up     {} e = rewrite r e+rew r@Opt    {} e = rewrite r e+rew r@If     {} e = rewrite r e+rew r@Hard   {} e = rewrite r e

@@ -0,0 +1,92 @@+module Plugin.Pl.Parser (parsePF) where++import           Plugin.Pl.Common++import qualified Language.Haskell.Exts as HSE++todo :: (Functor e, Show (e ())) => e a -> r+todo thing = error ("pointfree: not supported: " ++ show (void thing))++nameString :: HSE.Name a -> (Fixity, String)+nameString (HSE.Ident _ s)  = (Pref, s)+nameString (HSE.Symbol _ s) = (Inf, s)++qnameString :: HSE.QName a -> (Fixity, String)+qnameString (HSE.Qual _ m n) = fmap ((HSE.prettyPrint m ++ ".") ++) (nameString n)+qnameString (HSE.UnQual _ n) = nameString n+qnameString (HSE.Special _ sc) = case sc of+  HSE.UnitCon _              -> (Pref, "()")+  HSE.ListCon _              -> (Pref, "[]")+  HSE.FunCon _               -> (Inf, "->")+  HSE.TupleCon _ HSE.Boxed n -> (Inf, replicate (n-1) ',')+  HSE.TupleCon{}             -> todo sc+  HSE.Cons _                 -> (Inf, ":")+  HSE.UnboxedSingleCon{}     -> todo sc+  HSE.ExprHole{}             -> todo sc++opString :: HSE.QOp a -> (Fixity, String)+opString (HSE.QVarOp _ qn) = qnameString qn+opString (HSE.QConOp _ qn) = qnameString qn++list :: [Expr] -> Expr+list = foldr (\y ys -> cons `App` y `App` ys) nil++hseToExpr :: HSE.Exp a -> Expr+hseToExpr expr = case expr of+  HSE.Var _ qn -> uncurry Var (qnameString qn)+  HSE.IPVar{} -> todo expr+  HSE.Con _ qn -> uncurry Var (qnameString qn)+  HSE.Lit _ l -> case l of+    HSE.String _ _ s -> list (map (Var Pref . show) s)+    _                -> Var Pref (HSE.prettyPrint l)+  HSE.InfixApp _ p op q -> apps (Var Inf (snd (opString op))) [p,q]+  HSE.App _ f x -> hseToExpr f `App` hseToExpr x+  HSE.NegApp _ e -> Var Pref "negate" `App` hseToExpr e+  HSE.Lambda _ ps e -> foldr (Lambda . hseToPattern) (hseToExpr e) ps+  HSE.Let _ bs e -> case bs of+    HSE.BDecls _ ds   -> Let (map hseToDecl ds) (hseToExpr e)+    HSE.IPBinds _ ips -> todo ips+  HSE.If _ b t f -> apps if' [b,t,f]+  HSE.Case{} -> todo expr+  HSE.Do{} -> todo expr+  HSE.MDo{} -> todo expr+  HSE.Tuple _ HSE.Boxed es -> apps (Var Inf (replicate (length es - 1) ','))  es+  HSE.TupleSection{} -> todo expr+  HSE.List _ xs -> list (map hseToExpr xs)+  HSE.Paren _ e -> hseToExpr e+  HSE.LeftSection _ l op -> Var Inf (snd (opString op)) `App` hseToExpr l+  HSE.RightSection _ op r -> flip' `App` Var Inf (snd (opString op)) `App` hseToExpr r+  HSE.RecConstr{} -> todo expr+  HSE.RecUpdate{} -> todo expr+  HSE.EnumFrom _ x -> apps (Var Pref "enumFrom") [x]+  HSE.EnumFromTo _ x y -> apps (Var Pref "enumFromTo") [x,y]+  HSE.EnumFromThen _ x y -> apps (Var Pref "enumFromThen") [x,y]+  HSE.EnumFromThenTo _ x y z -> apps (Var Pref "enumFromThenTo") [x,y,z]+  _ -> todo expr++apps :: Expr -> [HSE.Exp a] -> Expr+apps = foldl (\a x -> a `App` hseToExpr x)++hseToDecl :: HSE.Decl a -> Decl+hseToDecl dec = case dec of+  HSE.PatBind _ (HSE.PVar _ n) (HSE.UnGuardedRhs _ e) Nothing ->+    Define (snd (nameString n)) (hseToExpr e)+  HSE.FunBind _ [HSE.Match _ n ps (HSE.UnGuardedRhs _ e) Nothing] ->+    Define (snd (nameString n)) (foldr (\p x -> Lambda (hseToPattern p) x) (hseToExpr e) ps)+  _ -> todo dec++hseToPattern :: HSE.Pat a -> Pattern+hseToPattern pat = case pat of+  HSE.PVar _ n -> PVar (snd (nameString n))+  HSE.PInfixApp _ l (HSE.Special _ (HSE.Cons _)) r -> PCons (hseToPattern l) (hseToPattern r)+  HSE.PTuple _ HSE.Boxed [p,q] -> PTuple (hseToPattern p) (hseToPattern q)+  HSE.PParen _ p -> hseToPattern p+  HSE.PWildCard _ -> PVar "_"+  _ -> todo pat++parsePF :: String -> Either String TopLevel+parsePF inp = case HSE.parseExp inp of+  HSE.ParseOk e -> Right (TLE (hseToExpr e))+  HSE.ParseFailed _ _ -> case HSE.parseDecl inp of+    HSE.ParseOk d         -> Right (TLD True (hseToDecl d))+    HSE.ParseFailed _ err -> Left err

@@ -0,0 +1,146 @@+{-# LANGUAGE PatternGuards #-}+module Plugin.Pl.PrettyPrinter (+  prettyDecl,+  prettyExpr,+  prettyTopLevel,+ ) where++import           Plugin.Pl.Common++import           Data.Char+import           Data.List        (intercalate)++prettyDecl :: Decl -> String+prettyDecl (Define f e) = f ++ " = " ++ prettyExpr e++prettyDecls :: [Decl] -> String+prettyDecls = intercalate "; " . map prettyDecl++prettyExpr :: Expr -> String+prettyExpr = show . toSExpr++prettyTopLevel :: TopLevel -> String+prettyTopLevel (TLE e)   = prettyExpr e+prettyTopLevel (TLD _ d) = prettyDecl d++data SExpr+  = SVar !String+  | SLambda ![Pattern] !SExpr+  | SLet ![Decl] !SExpr+  | SApp !SExpr !SExpr+  | SInfix !String !SExpr !SExpr+  | LeftSection !String !SExpr  -- (x +)+  | RightSection !String !SExpr -- (+ x)+  | List ![SExpr]+  | Tuple ![SExpr]+  | Enum !Expr !(Maybe Expr) !(Maybe Expr)++{-# INLINE toSExprHead #-}+toSExprHead :: String -> [Expr] -> Maybe SExpr+toSExprHead hd tl+  | all (==',') hd, length hd+1 == length tl+  = Just . Tuple . reverse $ map toSExpr tl+  | otherwise = case (hd,reverse tl) of+      ("enumFrom", [e])              -> Just $ Enum e Nothing   Nothing+      ("enumFromThen", [e,e'])       -> Just $ Enum e (Just e') Nothing+      ("enumFromTo", [e,e'])         -> Just $ Enum e Nothing   (Just e')+      ("enumFromThenTo", [e,e',e'']) -> Just $ Enum e (Just e') (Just e'')+      _                              -> Nothing++toSExpr :: Expr -> SExpr+toSExpr (Var _ v) = SVar v+toSExpr (Lambda v e) = case toSExpr e of+  (SLambda vs e') -> SLambda (v:vs) e'+  e'              -> SLambda [v] e'+toSExpr (Let ds e) = SLet ds $ toSExpr e+toSExpr e | Just (hd,tl) <- getHead e, Just se <- toSExprHead hd tl = se+toSExpr e | (ls, tl) <- getList e, tl == nil+  = List $ map toSExpr ls+toSExpr (App e1 e2) = case e1 of+  App (Var Inf v) e0+    -> SInfix v (toSExpr e0) (toSExpr e2)+  Var Inf v | v /= "-"+    -> LeftSection v (toSExpr e2)++  Var _ "flip" | Var Inf v <- e2, v == "-" -> toSExpr $ Var Pref "subtract"++  App (Var _ "flip") (Var pr v)+    | v == "-"  -> toSExpr $ Var Pref "subtract" `App` e2+    | v == "id" -> RightSection "$" (toSExpr e2)+    | Inf <- pr, any (/= ',') v -> RightSection v (toSExpr e2)+  _ -> SApp (toSExpr e1) (toSExpr e2)++getHead :: Expr -> Maybe (String, [Expr])+getHead (Var _ v)   = Just (v, [])+getHead (App e1 e2) = second (e2:) `fmap` getHead e1+getHead _           = Nothing++instance Show SExpr where+  showsPrec _ (SVar v) = (getPrefName v ++)+  showsPrec p (SLambda vs e) = showParen (p > minPrec) $ ('\\':) .+    foldr (.) id (intersperse (' ':) (map (prettyPrecPattern $ maxPrec+1) vs)) .+    (" -> "++) . showsPrec minPrec e+  showsPrec p (SApp e1 e2) = showParen (p > maxPrec) $+    showsPrec maxPrec e1 . (' ':) . showsPrec (maxPrec+1) e2+  showsPrec _ (LeftSection fx e) = showParen True $+    showsPrec (snd (lookupFix fx) + 1) e . (' ':) . (getInfName fx++)+  showsPrec _ (RightSection fx e) = showParen True $+    (getInfName fx++) . (' ':) . showsPrec (snd (lookupFix fx) + 1) e+  showsPrec _ (Tuple es) = showParen True+    (join `id` intersperse ", " (map show es) ++)++  showsPrec _ (List es)+    | Just cs <- mapM ((=<<) readM . fromSVar) es = shows (cs::String)+    | otherwise = ('[':) .+      (join `id` intersperse ", " (map show es) ++) . (']':)+    where fromSVar (SVar str) = Just str+          fromSVar _          = Nothing+  showsPrec _ (Enum fr tn to) = ('[':) . showString (prettyExpr fr) .+    showsMaybe (((',':) . prettyExpr) `fmap` tn) . (".."++) .+    showsMaybe (prettyExpr `fmap` to) . (']':)+      where showsMaybe = maybe id (++)+  showsPrec _ (SLet ds e) = ("let "++) . showString (prettyDecls ds ++ " in ") . shows e+++  showsPrec p (SInfix fx e1 e2) = showParen (p > fixity) $+    showsPrec f1 e1 . (' ':) . (getInfName fx++) . (' ':) .+    showsPrec f2 e2 where+      fixity = snd $ lookupFix fx+      (f1, f2) = case fst $ lookupFix fx of+        AssocRight _ -> (fixity+1, fixity + infixSafe e2 (AssocLeft ()) fixity)+        AssocLeft _ -> (fixity + infixSafe e1 (AssocRight ()) fixity, fixity+1)+        AssocNone _ -> (fixity+1, fixity+1)++      -- This is a little bit awkward, but at least seems to produce no false+      -- results anymore+      infixSafe :: SExpr -> Assoc () -> Int -> Int+      infixSafe (SInfix fx'' _ _) assoc fx'+        | lookupFix fx'' == (assoc, fx') = 1+        | otherwise = 0+      infixSafe _ _ _ = 0 -- doesn't matter++prettyPrecPattern :: Int -> Pattern -> ShowS+prettyPrecPattern _ (PVar v) = showString v+prettyPrecPattern _ (PTuple p1 p2) = showParen True $+  prettyPrecPattern 0 p1 . (", "++) . prettyPrecPattern 0 p2+prettyPrecPattern p (PCons p1 p2) = showParen (p>5) $+  prettyPrecPattern 6 p1 . (':':) . prettyPrecPattern 5 p2++isOperator :: String -> Bool+isOperator s =+  case break (== '.') s of+    (_, "") -> isUnqualOp s+    (before, _dot : rest)+      | isUnqualOp before -> isUnqualOp rest+      | isModule before -> isOperator rest+      | otherwise -> False+  where+    isModule "" = False+    isModule (c : cs) = isUpper c && all (\c' -> isAlphaNum c' || c' `elem` ['\'', '_']) cs+    isUnqualOp s' = s' /= "()" && all (\c -> isSymbol c || isPunctuation c) s'++getInfName :: String -> String+getInfName str = if isOperator str then str else "`"++str++"`"++getPrefName :: String -> String+getPrefName str = if isOperator str || ',' `elem` str then "("++str++")" else str

@@ -0,0 +1,875 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE PatternGuards             #-}+{-# LANGUAGE ScopedTypeVariables       #-}+--+-- | This marvellous module contributed by Thomas J\344ger+--+module Plugin.Pl.Rules (RewriteRule(..), rules, fire) where++import           Plugin.Pl.Common++import           Data.Array+import qualified Data.Set          as S++import           Control.Monad.Fix (fix)++--import PlModule.PrettyPrinter++-- Next time I do somthing like this, I'll actually think about the combinator+-- language before, instead of producing something ad-hoc like this:+data RewriteRule+  = RR Rewrite Rewrite+  | CRR (Expr -> Maybe Expr)+  | Down RewriteRule RewriteRule+  | Up RewriteRule RewriteRule+  | Or [RewriteRule]+  | OrElse RewriteRule RewriteRule+  | Then RewriteRule RewriteRule+  | Opt RewriteRule+  | If RewriteRule RewriteRule+  | Hard RewriteRule++-- No MLambda here because we only consider closed Terms (no alpha-renaming!).+data MExpr+  = MApp !MExpr !MExpr+  | Hole !Int+  | Quote !Expr+  deriving Eq++--instance Show MExpr where+--  show = show . fromMExpr++data Rewrite = Rewrite {+  holes :: MExpr,+  rid   :: Int -- rlength - 1+} --deriving Show++-- What are you gonna do when no recursive modules are possible?+class RewriteC a where+  getRewrite :: a -> Rewrite++instance RewriteC MExpr where+  getRewrite rule = Rewrite {+    holes   = rule,+    rid = 0+  }++type ExprArr = Array Int Expr++myFire :: ExprArr -> MExpr -> MExpr+myFire xs (MApp e1 e2) = MApp (myFire xs e1) (myFire xs e2)+myFire xs (Hole h)     = Quote $ xs ! h+myFire _ me            = me++nub' :: Ord a => [a] -> [a]+nub' = S.toList . S.fromList++uniqueArray :: Ord v => Int -> [(Int, v)] -> Maybe (Array Int v)+uniqueArray n lst+  | length (nub' lst) == n = Just $ array (0,n-1) lst+  | otherwise = Nothing++match :: Rewrite -> Expr -> Maybe ExprArr+match (Rewrite hl rid') e  = uniqueArray rid' =<< matchWith hl e++fire' :: Rewrite -> ExprArr -> MExpr+fire' (Rewrite hl _)   = (`myFire` hl)++fire :: Rewrite -> Rewrite -> Expr -> Maybe Expr+fire r1 r2 e = (fromMExpr . fire' r2) `fmap` match r1 e++matchWith :: MExpr -> Expr -> Maybe [(Int, Expr)]+matchWith (MApp e1 e2) (App e1' e2') =+  liftM2 (++) (matchWith e1 e1') (matchWith e2 e2')+matchWith (Quote e) e' = if e == e' then Just [] else Nothing+matchWith (Hole k) e = Just [(k,e)]+matchWith _ _ = Nothing++fromMExpr :: MExpr -> Expr+fromMExpr (MApp e1 e2) = App (fromMExpr e1) (fromMExpr e2)+fromMExpr (Hole _)     = Var Pref "Hole" -- error "Hole in MExpr"+fromMExpr (Quote e)    = e++instance RewriteC a => RewriteC (MExpr -> a) where+  getRewrite rule = Rewrite {+    holes = holes . getRewrite . rule . Hole $ pid,+    rid   = pid + 1+  } where+    pid = rid $ getRewrite (bt :: a)++-- Yet another pointless transformation+transformM :: Int -> MExpr -> MExpr+transformM _ (Quote e) = constE `a` Quote e+transformM n (Hole n') = if n == n' then idE else constE `a` Hole n'+transformM n (Quote (Var _ ".") `MApp` e1 `MApp` e2)+  | e1 `hasHole` n && not (e2 `hasHole` n)+  = flipE `a` compE `a` e2 `c` transformM n e1+transformM n e@(MApp e1 e2)+  | fr1 && fr2 = sE `a` transformM n e1 `a` transformM n e2+  | fr1        = flipE `a` transformM n e1 `a` e2+  | fr2, Hole n' <- e2, n' == n = e1+  | fr2        = e1 `c` transformM n e2+  | otherwise  = constE `a` e+  where+    fr1 = e1 `hasHole` n+    fr2 = e2 `hasHole` n++hasHole :: MExpr -> Int -> Bool+hasHole (MApp e1 e2) n = e1 `hasHole` n || e2 `hasHole` n+hasHole (Quote _)   _  = False+hasHole (Hole n')   n  = n == n'++--+-- haddock doesn't like n+k patterns, so rewrite them+--+getVariants, getVariants' :: Rewrite -> [Rewrite]+getVariants' r@(Rewrite _ 0)  = [r]+getVariants' r@(Rewrite e nk)+    | nk >= 1    = r : getVariants (Rewrite e' (nk-1))+    | otherwise  = error "getVariants' : nk went negative"+    where+        e' = decHoles $ transformM 0 e++        decHoles (Hole n')    = Hole (n'-1)+        decHoles (MApp e1 e2) = decHoles e1 `MApp` decHoles e2+        decHoles me           = me++getVariants = getVariants' -- r = trace (show vs) vs where vs = getVariants' r++rr, rr0, rr1, rr2 :: RewriteC a => a -> a -> RewriteRule+-- use this rewrite rule and rewrite rules derived from it by iterated+-- pointless transformation+rrList :: RewriteC a => a -> a -> [RewriteRule]+rrList r1 r2 = zipWith RR (getVariants r1') (getVariants r2') where+  r1' = getRewrite r1+  r2' = getRewrite r2++rr  r1 r2 = Or          $ rrList r1 r2+rr1 r1 r2 = Or . take 2 $ rrList r1 r2+rr2 r1 r2 = Or . take 3 $ rrList r1 r2++-- use only this rewrite rule+rr0 r1 r2 = RR r1' r2' where+  r1' = getRewrite r1+  r2' = getRewrite r2++down, up :: RewriteRule -> RewriteRule+down = fix . Down+up   = fix . Up+++idE, flipE, bindE, extE, returnE, consE, appendE, nilE, foldrE, foldlE, fstE,+  sndE, dollarE, constE, uncurryE, curryE, compE, headE, tailE, sE, commaE,+  fixE, foldl1E, notE, equalsE, nequalsE, plusE, multE, zeroE, oneE, lengthE,+  sumE, productE, concatE, concatMapE, joinE, mapE, fmapE, fmapIE, subtractE,+  minusE, liftME, apE, liftM2E, seqME, zipE, zipWithE, onE, oedipusE, comp2E,+  crossE, firstE, secondE, andE, orE, allE, anyE :: MExpr+idE        = Quote $ Var Pref "id"+flipE      = Quote $ Var Pref "flip"+constE     = Quote $ Var Pref "const"+compE      = Quote $ Var Inf "."+comp2E     = Quote $ Var Inf ".*"+comp3E     = Quote $ Var Inf ".**"+eyeE       = Quote $ Var Inf "-."+oedipusE   = Quote $ Var Inf "-.*"+oedipus2E  = Quote $ Var Inf "-.**"+onE        = Quote $ Var Pref "on"+ampersandE = Quote $ Var Inf "&"+sE         = Quote $ Var Pref "ap"+fixE       = Quote $ Var Pref "fix"+bindE      = Quote $ Var Inf  ">>="+extE       = Quote $ Var Inf  "=<<"+returnE    = Quote $ Var Pref "return"+consE      = Quote $ Var Inf  ":"+nilE       = Quote $ Var Pref "[]"+appendE    = Quote $ Var Inf  "++"+foldrE     = Quote $ Var Pref "foldr"+foldlE     = Quote $ Var Pref "foldl"+fstE       = Quote $ Var Pref "fst"+sndE       = Quote $ Var Pref "snd"+dollarE    = Quote $ Var Inf  "$"+uncurryE   = Quote $ Var Pref "uncurry"+curryE     = Quote $ Var Pref "curry"+headE      = Quote $ Var Pref "head"+tailE      = Quote $ Var Pref "tail"+commaE     = Quote $ Var Inf  ","+foldl1E    = Quote $ Var Pref "foldl1"+equalsE    = Quote $ Var Inf  "=="+nequalsE   = Quote $ Var Inf  "/="+notE       = Quote $ Var Pref "not"+plusE      = Quote $ Var Inf  "+"+multE      = Quote $ Var Inf  "*"+zeroE      = Quote $ Var Pref "0"+oneE       = Quote $ Var Pref "1"+lengthE    = Quote $ Var Pref "length"+sumE       = Quote $ Var Pref "sum"+productE   = Quote $ Var Pref "product"+concatE    = Quote $ Var Pref "concat"+concatMapE = Quote $ Var Pref "concatMap"+joinE      = Quote $ Var Pref "join"+mapE       = Quote $ Var Pref "map"+fmapE      = Quote $ Var Pref "fmap"+fmapIE     = Quote $ Var Inf  "fmap"+subtractE  = Quote $ Var Pref "subtract"+minusE     = Quote $ Var Inf  "-"+liftME     = Quote $ Var Pref "liftM"+liftM2E    = Quote $ Var Pref "liftM2"+fishE      = Quote $ Var Inf  ">=>"+kliesliE   = Quote $ Var Inf "<=<"+apE        = Quote $ Var Inf  "ap"+seqME      = Quote $ Var Inf  ">>"+zipE       = Quote $ Var Pref "zip"+zipWithE   = Quote $ Var Pref "zipWith"+crossE     = Quote $ Var Inf  "***"+firstE     = Quote $ Var Pref "first"+secondE    = Quote $ Var Pref "second"+andE       = Quote $ Var Pref "and"+orE        = Quote $ Var Pref "or"+allE       = Quote $ Var Pref "all"+anyE       = Quote $ Var Pref "any"+replaceE   = Quote $ Var Inf "<$"+pointyE    = Quote $ Var Inf "$>"++++a, c, c2 :: MExpr -> MExpr -> MExpr+a       = MApp+c e1 e2 = compE `a` e1 `a` e2+c2 e1 e2 = comp2E `a` e1 `a` e2+c3 e1 e2 = comp3E `a` e1 `a` e2+o e1 e2 = oedipusE `a` e1 `a` e2+o2 e1 e2 = oedipus2E `a` e1 `a` e2+eye e1 e2 = eyeE `a` e1 `a` e2+infixl 9 `a`+infixr 8 `c`+infixr 8 `c2`+infixr 8 `o`+++collapseLists :: Expr -> Maybe Expr+collapseLists (Var _ "++" `App` e1 `App` e2)+  | (xs,x) <- getList e1, x==nil,+    (ys,y) <- getList e2, y==nil = Just $ makeList $ xs ++ ys+collapseLists _ = Nothing++data Binary = forall a b c. (Read a, Show a, Read b, Show b, Read c, Show c) => BA (a -> b -> c)++evalBinary :: [(String, Binary)] -> Expr -> Maybe Expr+evalBinary fs (Var _ f' `App` Var _ x' `App` Var _ y')+  | Just (BA f) <- lookup f' fs = (Var Pref . show) `fmap` liftM2 f (readM x') (readM y')+evalBinary _ _ = Nothing++data Unary = forall a b. (Read a, Show a, Read b, Show b) => UA (a -> b)++evalUnary :: [(String, Unary)] -> Expr -> Maybe Expr+evalUnary fs (Var _ f' `App` Var _ x')+  | Just (UA f) <- lookup f' fs = (Var Pref . show . f) `fmap` readM x'+evalUnary _ _ = Nothing++assocR, assocL, assoc :: [String] -> Expr -> Maybe Expr+-- (f `op` g) `op` h --> f `op` (g `op` h)+assocR ops (Var f1 op1 `App` (Var f2 op2 `App` e1 `App` e2) `App` e3)+  | op1 == op2 && op1 `elem` ops+  = Just (Var f1 op1 `App` e1 `App` (Var f2 op2 `App` e2 `App` e3))+assocR _ _ = Nothing++-- f `op` (g `op` h) --> (f `op` g) `op` h+assocL ops (Var f1 op1 `App` e1 `App` (Var f2 op2 `App` e2 `App` e3))+  | op1 == op2 && op1 `elem` ops+  = Just (Var f1 op1 `App` (Var f2 op2 `App` e1 `App` e2) `App` e3)+assocL _ _ = Nothing++-- op f . op g --> op (f `op` g)+assoc ops (Var _ "." `App` (Var f1 op1 `App` e1) `App` (Var f2 op2 `App` e2))+  | op1 == op2 && op1 `elem` ops+  = Just (Var f1 op1 `App` (Var f2 op2 `App` e1 `App` e2))+assoc _ _ = Nothing++commutative :: [String] -> Expr -> Maybe Expr+commutative ops (Var f op `App` e1 `App` e2)+  | op `elem` ops = Just (Var f op `App` e2 `App` e1)+commutative ops (Var _ "flip" `App` e@(Var _ op)) | op `elem` ops = Just e+commutative _ _ = Nothing++-- TODO: Move rules into a file.+{-# INLINE simplifies #-}+simplifies :: RewriteRule+simplifies = Or [+  -- (f . g) x --> f (g x)+  rr0 (\f g x -> (f `c` g) `a` x)+      (\f g x -> f `a` (g `a` x)),+  -- (g -. f) -> f (g x)+  rr0 (\f g x -> (f `eye` g) `a` x)+      (\f g x -> f `a` (g `a` x)),+  -- (f .* g) x y -> f (g x y)+  rr0  (\f g x y -> (f `c2` g) `a` x `a` y)+       (\f g x y -> f `a` (g `a` x `a` y)),+  -- (f .** g) x y z -> f (g x y z)+  rr0 (\f g x y z -> (f `c3` g) `a` x `a` y `a` z)+      (\f g x y z -> f `a` (g `a` x `a` y `a` z)),+  -- (f -.* g) x y -> f x (g y)+  rr0  (\f g x y -> (f `o` g) `a` x `a` y)+       (\f g x y -> f `a` x `a` (g `a` y)),+  -- (f -.** g) -> f x y (g z)+  rr0 (\f g x y z -> (f `o2` g) `a` x `a` y `a` z)+      (\f g x y z -> f `a` x `a` y `a` (g `a` z)),+  -- x & f -> f x+  rr0 (\f x -> x `a` ampersandE `a` f)+      a,+  -- id x --> x+  rr0 (\x -> idE `a` x)+      id,+  -- flip (flip x) --> x+  rr  (\x -> flipE `a` (flipE `a` x))+      id,+  -- flip id x . f --> flip f x+  rr0 (\f x -> (flipE `a` idE `a` x) `c` f)+      (\f x -> flipE `a` f `a` x),+  -- id . f --> f+  rr0 (\f -> idE `c` f)+      id,+  -- f . id --> f+  rr0 (`c` idE)+      id,+  -- const x y --> x+  rr0 (\x y -> constE `a` x `a` y)+      const,+  -- not (not x) --> x+  rr  (\x -> notE `a` (notE `a` x))+      id,+  -- fst (x,y) --> x+  rr  (\x y -> fstE `a` (commaE `a` x `a` y))+      const,+  -- snd (x,y) --> y+  rr  (\x y -> sndE `a` (commaE `a` x `a` y))+      (\_ y -> y),+  -- head (x:xs) --> x+  rr  (\x xs -> headE `a` (consE `a` x `a` xs))+      const,+  -- tail (x:xs) --> xs+  rr  (\x xs -> tailE `a` (consE `a` x `a` xs))+      (\_ xs -> xs),+  -- uncurry f (x,y) --> f x y+  rr1 (\f x y -> uncurryE `a` f `a` (commaE `a` x `a` y))+      (\f x y -> f `a` x `a` y),+  -- uncurry (,) --> id+  rr  (uncurryE `a` commaE)+      idE,+  -- uncurry f . s (,) g --> s f g+  rr1 (\f g -> (uncurryE `a` f) `c` (sE `a` commaE `a` g))+      (\f g -> sE `a` f `a` g),+  -- curry fst --> const+  rr (curryE `a` fstE) constE,+  -- curry snd --> const id+  rr (curryE `a` sndE) (constE `a` idE),+  -- s f g x --> f x (g x)+  rr0 (\f g x -> sE `a` f `a` g `a` x)+      (\f g x -> f `a` x `a` (g `a` x)),+  -- flip f x y --> f y x+  rr0 (\f x y -> flipE `a` f `a` x `a` y)+      (\f x y -> f `a` y `a` x),+  -- flip (=<<) --> (>>=)+  rr0 (flipE `a` extE)+      bindE,++  -- TODO: Think about map/fmap+  -- fmap id --> id+  rr (fmapE `a` idE)+     idE,+  -- map id --> id+  rr (mapE `a` idE)+     idE,+  -- (f . g) . h --> f . (g . h)+  rr0 (\f g h -> (f `c` g) `c` h)+      (\f g h -> f `c` (g `c` h)),+  -- fmap f . fmap g -> fmap (f . g)+  rr0 (\f g -> fmapE `a` f `c` fmapE `a` g)+      (\f g -> fmapE `a` (f `c` g)),+  -- map f . map g -> map (f . g)+  rr0 (\f g -> mapE `a` f `c` mapE `a` g)+      (\f g -> mapE `a` (f `c` g))++  ]++onceRewrites :: RewriteRule+onceRewrites = Hard $ Or [+  -- ($) --> id+  rr0 dollarE+      idE,+  -- concatMap --> (=<<)+  rr concatMapE extE,+  -- concat    --> join+  rr concatE joinE,+  -- liftM --> fmap+  rr liftME fmapE,+  -- map --> fmap+  rr mapE fmapE,+  -- subtract -> flip (-)+  rr  subtractE+      (flipE `a` minusE)+  ]++-- Now we can state rewrite rules in a nice high level way+-- Rewrite rules should be as pointful as possible since the pointless variants+-- will be derived automatically.+rules :: RewriteRule+rules = Or [+  -- f (g x) --> (f . g) x+  Hard $+  rr  (\f g x -> f `a` (g `a` x))+      (\f g x -> (f `c` g) `a` x),+  -- (>>=) --> flip (=<<)+  -- (>>=) --> flip (=<<)+  Hard $+  rr  bindE+      (flipE `a` extE),+  -- (.) id --> id+  rr (compE `a` idE)+     idE,+  -- (++) [x] --> (:) x+  rr  (\x -> appendE `a` (consE `a` x `a` nilE))+      (\x -> consE `a` x),+  -- (=<<) return --> id+  rr  (extE `a` returnE)+      idE,+  -- (=<<) f (return x) -> f x+  rr  (\f x -> extE `a` f `a` (returnE `a` x))+      a,+  -- (=<<) ((=<<) f . g) --> (=<<) f . (=<<) g+  rr  (\f g -> extE `a` ((extE `a` f) `c` g))+      (\f g -> (extE `a` f) `c` (extE `a` g)),+  -- flip (f . g) --> flip (.) g . flip f+  Hard $+  rr  (\f g -> flipE `a` (f `c` g))+      (\f g -> (flipE `a` compE `a` g) `c` (flipE `a` f)),+  -- flip (.) f . flip id --> flip f+  rr  (\f -> (flipE `a` compE `a` f) `c` (flipE `a` idE))+      (\f -> flipE `a` f),+  -- flip (.) f . flip flip --> flip (flip . f)+  rr  (\f -> (flipE `a` compE `a` f) `c` (flipE `a` flipE))+      (\f -> flipE `a` (flipE `c` f)),+  -- flip (flip (flip . f) g) --> flip (flip . flip f) g+  rr1 (\f g -> flipE `a` (flipE `a` (flipE `c` f) `a` g))+      (\f g -> flipE `a` (flipE `c` flipE `a` f) `a` g),++  -- flip (.) id --> id+  rr (flipE `a` compE `a` idE)+     idE,+  -- (.) . flip id --> flip flip+  rr  (compE `c` (flipE `a` idE))+      (flipE `a` flipE),+  -- s const x y --> y+  rr  (\x y -> sE `a` constE `a` x `a` y)+      (\_ y -> y),+  -- s (const . f) g --> f+  rr1 (\f g -> sE `a` (constE `c` f) `a` g)+      const,+  -- s (const f) --> (.) f+  rr  (\f -> sE `a` (constE `a` f))+      (\f -> compE `a` f),+  -- s (f . fst) snd --> uncurry f+  rr  (\f -> sE `a` (f `c` fstE) `a` sndE)+      (\f -> uncurryE `a` f),+  -- fst (join (,) x) --> x+  rr (\x -> fstE `a` (joinE `a` commaE `a` x))+     id,+  -- snd (join (,) x) --> x+  rr (\x -> sndE `a` (joinE `a` commaE `a` x))+     id,+  -- The next two are `simplifies', strictly speaking, but invoked rarely.+  -- uncurry f (x,y) --> f x y+  rr  (\f x y -> uncurryE `a` f `a` (commaE `a` x `a` y))+      (\f x y -> f `a` x `a` y),+  -- curry (uncurry f) --> f+  rr (\f -> curryE `a` (uncurryE `a` f))+     id,+  -- uncurry (curry f) --> f+  rr (\f -> uncurryE `a` (curryE `a` f))+     id,+  -- (const id . f) --> const id+  rr  (\f -> (constE `a` idE) `c` f)+      (\_ -> constE `a` idE),+  -- const x . f --> const x+  rr (\x f -> constE `a` x `c` f)+     (\x _ -> constE `a` x),+  -- fix f --> f (fix x)+  Hard $+  rr0 (\f -> fixE `a` f)+      (\f -> f `a` (fixE `a` f)),+  -- f (fix f) --> fix x+  Hard $+  rr0 (\f -> f `a` (fixE `a` f))+      (\f -> fixE `a` f),+  -- fix f --> f (f (fix x))+  Hard $+  rr0 (\f -> fixE `a` f)+      (\f -> f `a` (f `a` (fixE `a` f))),+  -- fix (const f) --> f+  rr (\f -> fixE `a` (constE `a` f))+     id,+  -- flip const x --> id+  rr  (\x -> flipE `a` constE `a` x)+      (pure idE),+  -- const . f --> flip (const f)+  Hard $+  rr  (\f -> constE `c` f)+      (\f -> flipE `a` (constE `a` f)),+  -- not (x == y) -> x /= y+  rr2 (\x y -> notE `a` (equalsE `a` x `a` y))+      (\x y -> nequalsE `a` x `a` y),+  -- not (x /= y) -> x == y+  rr2 (\x y -> notE `a` (nequalsE `a` x `a` y))+      (\x y -> equalsE `a` x `a` y),+  If (Or [rr plusE plusE, rr minusE minusE, rr multE multE]) $ down $ Or [+    -- 0 + x --> x+    rr  (\x -> plusE `a` zeroE `a` x)+        id,+    -- 0 * x --> 0+    rr  (\x -> multE `a` zeroE `a` x)+        (pure zeroE),+    -- 1 * x --> x+    rr  (\x -> multE `a` oneE `a` x)+        id,+    -- x - x --> 0+    rr  (\x -> minusE `a` x `a` x)+        (pure zeroE),+    -- x - y + y --> x+    rr  (\y x -> plusE `a` (minusE `a` x `a` y) `a` y)+        (\_ x -> x),+    -- x + y - y --> x+    rr  (\y x -> minusE `a` (plusE `a` x `a` y) `a` y)+        (\_ x -> x),+    -- x + (y - z) --> x + y - z+    rr  (\x y z -> plusE `a` x `a` (minusE `a` y `a` z))+        (\x y z -> minusE `a` (plusE `a` x `a` y) `a` z),+    -- x - (y + z) --> x - y - z+    rr  (\x y z -> minusE `a` x `a` (plusE `a` y `a` z))+        (\x y z -> minusE `a` (minusE `a` x `a` y) `a` z),+    -- x - (y - z) --> x + y - z+    rr  (\x y z -> minusE `a` x `a` (minusE `a` y `a` z))+        (\x y z -> minusE `a` (plusE `a` x `a` y) `a` z)+  ],++  -- flip ($) -> &+  rr (flipE `a` dollarE)+     ampersandE,++  -- fmap . const -> (<$)+  rr (fmapE `c` constE)+     replaceE,++  -- flip (<$) -> ($>)+  Hard $+  rr (flipE `a` replaceE)+     pointyE,++  Hard onceRewrites,+  -- join (fmap f x) --> f =<< x+  rr (\f x -> joinE `a` (fmapE `a` f `a` x))+     (\f x -> extE `a` f `a` x),+  -- (=<<) id --> join+  rr (extE `a` idE) joinE,+  -- join --> (=<<) id+  Hard $+  rr joinE (extE `a` idE),+  -- join (return x) --> x+  rr (\x -> joinE `a` (returnE `a` x))+     id,+  -- (return . f) =<< m --> fmap f m+  rr (\f m -> extE `a` (returnE `c` f) `a` m)+     (\f m -> fmapIE `a` f `a` m),+  -- (x >>=) . (return .) . f  --> flip (fmap . f) x+  rr (\f x -> bindE `a` x `c` (compE `a` returnE) `c` f)+     (\f x -> flipE `a` (fmapIE `c` f) `a` x),+  -- (>>=) (return f) --> flip id f+  rr (\f -> bindE `a` (returnE `a` f))+     (\f -> flipE `a` idE `a` f),+  -- liftM2 f x --> ap (f `fmap` x)+  Hard $+  rr (\f x -> liftM2E `a` f `a` x)+     (\f x -> apE `a` (fmapIE `a` f `a` x)),+  -- liftM2 f (return x) --> fmap (f x)+  rr (\f x -> liftM2E `a` f `a` (returnE `a` x))+     (\f x -> fmapIE `a` (f `a` x)),+  -- f `fmap` return x --> return (f x)+  rr (\f x -> fmapE `a` f `a` (returnE `a` x))+     (\f x -> returnE `a` (f `a` x)),+  -- (=<<) . flip (fmap . f) --> flip liftM2 f+  Hard $+  rr (\f -> extE `c` flipE `a` (fmapE `c` f))+     (\f -> flipE `a` liftM2E `a` f),++  -- ((f .) .) . g --> (f .** g)+  Hard $ rr (\f g -> (compE `a` (compE `a` f)) `c` g)+     (\f g -> (comp3E `a` f `a` g)),++  -- (f .) . g --> (f .* g)+  Hard $ rr (\f g -> (compE `a` f) `c` g)+     (\f g -> comp2E `a` f `a` g),++  -- flip (.) -> (-.)+  rr (flipE `a` compE)+     eyeE,++  -- (x &) -> ($ x)+  rr (\x -> ampersandE `a` x)+     (\x -> dollarE `a` x),++  -- f -.* (g . f) -> on g f+  Hard $+  rr (\f g -> oedipusE `a` f `a` (compE `a` g `a` f))+     (\f g -> onE `a` g `a` f),++  -- (.) -> fmap+  Hard $+  rr compE fmapE,++  -- join .* map x y -> (=<<) x y+  Hard $+  rr (joinE `c2` mapE) extE,++  -- map f (zip xs ys) --> zipWith (curry f) xs ys+  Hard $+  rr (\f xs ys -> mapE `a` f `a` (zipE `a` xs `a` ys))+     (\f xs ys -> zipWithE `a` (curryE `a` f) `a` xs `a` ys),++  -- zipWith (,) --> zip (,)+  rr (zipWithE `a` commaE) zipE,++  -- all f --> and . map f+  Hard $+  rr (\f -> allE `a` f)+     (\f -> andE `c` mapE `a` f),+  -- and . map f --> all f+  rr (\f -> andE `c` mapE `a` f)+     (\f -> allE `a` f),+  -- any f --> or . map f+  Hard $+  rr (\f -> anyE `a` f)+     (\f -> orE `c` mapE `a` f),+  -- or . map f --> any f+  rr (\f -> orE `c` mapE `a` f)+     (\f -> anyE `a` f),++  -- return f `ap` x --> fmap f x+  rr (\f x -> apE `a` (returnE `a` f) `a` x)+     (\f x -> fmapIE `a` f `a` x),+  -- ap (f `fmap` x) --> liftM2 f x+  rr (\f x -> apE `a` (fmapIE `a` f `a` x))+     (\f x -> liftM2E `a` f `a` x),+  -- f `ap` x --> (`fmap` x) =<< f+  Hard $+  rr (\f x -> apE `a` f `a` x)+     (\f x -> extE `a` (flipE `a` fmapIE `a` x) `a` f),+  -- (`fmap` x) =<< f --> f `ap` x+  rr (\f x -> extE `a` (flipE `a` fmapIE `a` x) `a` f)+     (\f x -> apE `a` f `a` x),+  -- (x >>=) . flip (fmap . f) -> liftM2 f x+  rr (\f x -> bindE `a` x `c` flipE `a` (fmapE `c` f))+     (\f x -> liftM2E `a` f `a` x),++  -- (f =<< m) x --> f (m x) x+  rr0 (\f m x -> extE `a` f `a` m `a` x)+      (\f m x -> f `a` (m `a` x) `a` x),+  -- (fmap f g x) --> f (g x)+  rr0 (\f g x -> fmapE `a` f `a` g `a` x)+      (\f g x -> f `a` (g `a` x)),+  -- return x y --> y+  rr  (\y x -> returnE `a` x `a` y)+      const,+  -- liftM2 f g h x --> g x `h` h x+  rr0 (\f g h x -> liftM2E `a` f `a` g `a` h `a` x)+      (\f g h x -> f `a` (g `a` x) `a` (h `a` x)),+  -- ap f id --> join f+  rr  (\f -> apE `a` f `a` idE)+      (\f -> joinE `a` f),++  -- flip flip f . ((.) .* g) --> f -.** g+  Hard $+  rr (\f g -> (flipE `a` flipE `a` f `c` (compE `c2` g)))+     (\f g -> oedipus2E `a` f `a` g),++  -- (. f) . g --> (f -.* g)+  Hard $+  rr (\f g -> (flipE `a` compE `a` f) `c` g)+     (\f g -> oedipusE `a` f `a` g),++  -- (=<<) const q --> flip (>>) q+  Hard $ -- ??+  rr (\q p -> extE `a` (constE `a` q) `a` p)+     (\q p -> seqME `a` p `a` q),+  -- p >> q --> const q =<< p+  Hard $+  rr (\p q -> seqME `a` p `a` q)+     (\p q -> extE `a` (constE `a` q) `a` p),++  -- ap (f -.* ((,) . f . fst)) snd --> f (***) f+  Hard $+  rr (\f -> apE `a` (f `o` (commaE `c` f `c` fstE)) `a` sndE)+     (\f -> joinE `a` crossE `a` f),++  -- flip (=<<) --> >>=+  rr (flipE `a` extE)+     bindE,++  -- flip (>=>) --> <=<+  rr (flipE `a` fishE)+     kliesliE,++  -- (.) . (=<<) --> <=<+  rr (compE `c` extE)+     kliesliE,++  -- join . (g .* f) --> f >=> g+  Hard $+    rr (\f g -> joinE `c` (g `c2` f))+       (\f g -> fishE `a` f `a` g),++  -- (`ap` snd) . (fst -.* (flip =<< (.) .* ((,) .))) --> join (***)+  -- Hard $+  rr ((flipE `a` apE `a` sndE) `c` (fstE `o` (extE `a` flipE `a` (compE `c2` (compE `a` commaE)))))+     (joinE `a` crossE),++  -- experimental support for Control.Arrow stuff+  -- (costs quite a bit of performace)+  -- uncurry ((. g) . (,) . f) --> f *** g+  rr (\f g -> uncurryE `a` ((flipE `a` compE `a` g) `c` commaE `c` f))+     (\f g -> crossE `a` f `a` g),+  -- uncurry ((,) . f) --> first f+  rr (\f -> uncurryE `a` (commaE `c` f))+     (\f -> firstE `a` f),+  -- uncurry ((. g) . (,)) --> second g+  rr (\g -> uncurryE `a` ((flipE `a` compE `a` g) `c` commaE))+     (\g -> secondE `a` g),+  -- I think we need all three of them:+  -- uncurry (const f) --> f . snd+  rr (\f -> uncurryE `a` (constE `a` f))+     (`c` sndE),+  -- uncurry const --> fst+  rr (uncurryE `a` constE)+     fstE,+  -- uncurry (const . f) --> f . fst+  rr (\f -> uncurryE `a` (constE `c` f))+     (`c` fstE),++  -- TODO is this the right place?+  -- [x] --> return x+  Hard $+  rr (\x -> consE `a` x `a` nilE)+     (\x -> returnE `a` x),+  -- list destructors+  Hard $+  If (Or [rr consE consE, rr nilE nilE]) $ Or [+    down $ Or [+      -- length [] --> 0+      rr (lengthE `a` nilE)+         zeroE,+      -- length (x:xs) --> 1 + length xs+      rr (\x xs -> lengthE `a` (consE `a` x `a` xs))+         (\_ xs -> plusE `a` oneE `a` (lengthE `a` xs))+    ],+    -- map/fmap elimination+    down $ Or [+      -- map f (x:xs) --> f x: map f xs+      rr (\f x xs -> mapE `a` f `a` (consE `a` x `a` xs))+         (\f x xs -> consE `a` (f `a` x) `a` (mapE `a` f `a` xs)),+      -- fmap f (x:xs) --> f x: Fmap f xs+      rr (\f x xs -> fmapE `a` f `a` (consE `a` x `a` xs))+         (\f x xs -> consE `a` (f `a` x) `a` (fmapE `a` f `a` xs)),+      -- map f []     --> []+      rr (\f -> mapE `a` f `a` nilE)+         (pure nilE),+      -- fmap f []     --> []+      rr (\f -> fmapE `a` f `a` nilE)+         (pure nilE)+    ],+    -- foldr elimination+    down $ Or [+      -- foldr f z (x:xs) --> f x (foldr f z xs)+      rr (\f x xs z -> (foldrE `a` f `a` z) `a` (consE `a` x `a` xs))+         (\f x xs z -> (f `a` x) `a` (foldrE `a` f `a` z `a` xs)),+      -- foldr f z [] --> z+      rr (\f z -> foldrE `a` f `a` z `a` nilE)+         (\_ z -> z)+    ],+    -- foldl elimination+    down $ Opt (CRR $ assocL ["."]) `Then` Or [+      -- sum xs --> foldl (+) 0 xs+      rr (\xs -> sumE `a` xs)+         (\xs -> foldlE `a` plusE `a` zeroE `a` xs),+      -- product xs --> foldl (*) 1 xs+      rr (\xs -> productE `a` xs)+         (\xs -> foldlE `a` multE `a` oneE `a` xs),+      -- foldl1 f (x:xs) --> foldl f x xs+      rr (\f x xs -> foldl1E `a` f `a` (consE `a` x `a` xs))+         (\f x xs -> foldlE `a` f `a` x `a` xs),+      -- foldl f z (x:xs) --> foldl f (f z x) xs+      rr (\f z x xs -> (foldlE `a` f `a` z) `a` (consE `a` x `a` xs))+         (\f z x xs -> foldlE `a` f `a` (f `a` z `a` x) `a` xs),+      -- foldl f z [] --> z+      rr (\f z -> foldlE `a` f `a` z `a` nilE)+         (\_ z -> z),+      -- special rule:+      -- foldl f z [x] --> f z x+      rr (\f z x -> foldlE `a` f `a` z `a` (returnE `a` x))+         (\f z x -> f `a` z `a` x),+      rr (\f z x -> foldlE `a` f `a` z `a` (consE `a` x `a` nilE))+         (\f z x -> f `a` z `a` x)+    ] `OrElse` (+      -- (:) x --> (++) [x]+      Opt (rr0 (\x -> consE `a` x)+         (\x -> appendE `a` (consE `a` x `a` nilE))) `Then`+      -- More special rule: (:) x . (++) ys --> (++) (x:ys)+      up (rr0 (\x ys -> (consE `a` x) `c` (appendE `a` ys))+         (\x ys -> appendE `a` (consE `a` x `a` ys)))+      )+  ],++  -- Complicated Transformations+  CRR collapseLists,+  up $ Or [CRR (evalUnary unaryBuiltins), CRR (evalBinary binaryBuiltins)],+  up $ CRR (assoc assocOps),+  up $ CRR (assocL assocOps),+  up $ CRR (assocR assocOps),+  Up (CRR (commutative commutativeOps)) $ down $ Or [CRR $ assocL assocLOps,+                                                     CRR $ assocR assocROps],++  Hard simplifies+  ] `Then` Opt (up simplifies)+assocLOps, assocROps, assocOps :: [String]+assocLOps = ["+", "*", "&&", "||", "max", "min"]+assocROps = [".", "++", ".*", ".**"]+assocOps  = assocLOps ++ assocROps++commutativeOps :: [String]+commutativeOps = ["*", "+", "==", "/=", "max", "min"]++unaryBuiltins :: [(String,Unary)]+unaryBuiltins = [+    ("not",    UA (not    :: Bool -> Bool)),+    ("negate", UA (negate :: Integer -> Integer)),+    ("signum", UA (signum :: Integer -> Integer)),+    ("abs",    UA (abs    :: Integer -> Integer))+  ]++binaryBuiltins :: [(String,Binary)]+binaryBuiltins = [+    ("+",    BA ((+)  :: Integer -> Integer -> Integer)),+    ("-",    BA ((-)  :: Integer -> Integer -> Integer)),+    ("*",    BA ((*)  :: Integer -> Integer -> Integer)),+    ("^",    BA ((^)  :: Integer -> Integer -> Integer)),+    ("<",    BA ((<)  :: Integer -> Integer -> Bool)),+    (">",    BA ((>)  :: Integer -> Integer -> Bool)),+    ("==",   BA ((==) :: Integer -> Integer -> Bool)),+    ("/=",   BA ((/=) :: Integer -> Integer -> Bool)),+    ("<=",   BA ((<=) :: Integer -> Integer -> Bool)),+    (">=",   BA ((>=) :: Integer -> Integer -> Bool)),+    ("div",  BA (div  :: Integer -> Integer -> Integer)),+    ("mod",  BA (mod  :: Integer -> Integer -> Integer)),+    ("max",  BA (max  :: Integer -> Integer -> Integer)),+    ("min",  BA (min  :: Integer -> Integer -> Integer)),+    ("&&",   BA ((&&) :: Bool -> Bool -> Bool)),+    ("||",   BA ((||) :: Bool -> Bool -> Bool))+  ]

@@ -0,0 +1,146 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternGuards     #-}+module Plugin.Pl.Transform (+    transform,+  ) where++import           Control.Monad.Trans.State+import           Data.Graph                (flattenSCC, flattenSCCs,+                                            stronglyConnComp)+import qualified Data.Map                  as M+import           Data.Maybe+import           Plugin.Pl.Common++occursP :: String -> Pattern -> Bool+occursP v (PVar v')      = v == v'+occursP v (PTuple p1 p2) = v `occursP` p1 || v `occursP` p2+occursP v (PCons  p1 p2) = v `occursP` p1 || v `occursP` p2++freeIn :: String -> Expr -> Int+freeIn v (Var _ v') = fromEnum $ v == v'+freeIn v (Lambda pat e) = if v `occursP` pat then 0 else freeIn v e+freeIn v (App e1 e2) = freeIn v e1 + freeIn v e2+freeIn v (Let ds e') = if v `elem` map declName ds then 0+  else freeIn v e' + sum [freeIn v e | Define _ e <- ds]++isFreeIn :: String -> Expr -> Bool+isFreeIn v e = freeIn v e > 0++tuple :: [Expr] -> Expr+tuple  = foldr1 (\x y -> Var Inf "," `App` x `App` y)++tupleP :: [String] -> Pattern+tupleP vs = foldr1 PTuple $ PVar `map` vs++dependsOn :: [Decl] -> Decl -> [Decl]+dependsOn ds d = [d' | d' <- ds, declName d' `isFreeIn` declExpr d]++unLet :: Expr -> Expr+unLet (App e1 e2) = App (unLet e1) (unLet e2)+unLet (Let [] e) = unLet e+unLet (Let ds e) = unLet $+  Lambda (tupleP $ declName `map` dsYes) (Let dsNo e) `App`+    (fix' `App` Lambda (tupleP $ declName `map` dsYes)+                        (tuple  $ declExpr `map` dsYes))+    where+  comps = stronglyConnComp [(d',d',dependsOn ds d') | d' <- ds]+  dsYes = flattenSCC $ head comps+  dsNo = flattenSCCs $ tail comps++unLet (Lambda v e) = Lambda v (unLet e)+unLet (Var f x) = Var f x++type Env = M.Map String String++-- It's a pity we still need that for the pointless transformation.+-- Otherwise a newly created id/const/... could be bound by a lambda+-- e.g. transform' (\id x -> x) ==> transform' (\id -> id) ==> id+alphaRename :: Expr -> Expr+alphaRename e = alpha e `evalState` M.empty where+  alpha :: Expr -> State Env Expr+  alpha (Var f v)     = Var f . fromMaybe v . M.lookup v <$> get+  alpha (App e1 e2)   = liftM2 App (alpha e1) (alpha e2)+  alpha (Let _ _)     = assert False bt+  alpha (Lambda v e') = inEnv $ liftM2 Lambda (alphaPat v) (alpha e')++  -- act like a reader monad+  inEnv :: State s a -> State s a+  inEnv f = gets $ evalState f++  alphaPat (PVar v) = do+    fm <- get+    let v' = "$" ++ show (M.size fm)+    put $ M.insert v v' fm+    return $ PVar v'+  alphaPat (PTuple p1 p2) = liftM2 PTuple (alphaPat p1) (alphaPat p2)+  alphaPat (PCons p1 p2) = liftM2 PCons (alphaPat p1) (alphaPat p2)+++transform :: Expr -> Expr+transform = transform' . alphaRename . unLet++-- Infinite generator of variable names.+varNames :: [String]+varNames = flip replicateM usableChars =<< [1..]+  where+    usableChars = ['a'..'z']++-- First variable name not already in use+fresh :: [String] -> String+fresh variables = head . filter (not . flip elem variables) $ varNames++names :: Expr -> [String]+names (Var _ str)     = [str]+-- Lambda pattern names are rewritten to be meaningless/unwritable, so we don't+-- need to include them here. Variables from lambdas used in expressions are+-- also rewritten, but there's no reason to special-case it unless it's provably+-- poor-performing to scan over the result in `fresh`, which I doubt it is.+names (Lambda _ exp') = names exp'+names (App exp1 exp2) = names exp1 ++ names exp2+names (Let dlcs exp') = (dnames =<< dlcs) ++ names exp'+  where+    dnames (Define nm exp'') = nm : names exp''++transform' :: Expr -> Expr+transform' exp' = go exp'+  where+    -- Explicit sharing for readability+    vars = names exp'++    go Let {} =+      assert False bt+    go (Var f v) =+      Var f v+    go (App e1 e2) =+      App (go e1) (go e2)+    go (Lambda (PTuple p1 p2) e) =+      go $+        Lambda (PVar var) $ (Lambda p1 . Lambda p2 $ e) `App` f `App` s+      where+        var   = fresh vars+        f     = Var Pref "fst" `App` Var Pref var+        s     = Var Pref "snd" `App` Var Pref var+    go (Lambda (PCons p1 p2) e) =+      go $+        Lambda (PVar var) $ (Lambda p1 . Lambda p2 $ e) `App` f `App` s+      where+        var = fresh vars+        f   = Var Pref "head" `App` Var Pref var+        s   = Var Pref "tail" `App` Var Pref var+    go (Lambda (PVar v) e) =+      go $ getRidOfV e+      where+        getRidOfV (Var f v') | v == v'   = id'+                             | otherwise = const' `App` Var f v'+        getRidOfV l@(Lambda pat _) =+          assert (not $ v `occursP` pat) $ getRidOfV $ go l+        getRidOfV Let {} = assert False bt+        getRidOfV e'@(App e1 e2)+          | fr1 && fr2 = scomb `App` getRidOfV e1 `App` getRidOfV e2+          | fr1 = flip' `App` getRidOfV e1 `App` e2+          | Var _ v' <- e2, v' == v = e1+          | fr2 = comp `App` e1 `App` getRidOfV e2+          | otherwise = const' `App` e'+          where+            fr1 = v `isFreeIn` e1+            fr2 = v `isFreeIn` e2

@@ -1,42 +1,40 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where -import           Test.HUnit-import           Test.QuickCheck-+import           Data.Char               (isSpace)+import           Data.Foldable           (fold) import           Plugin.Pl.Common import           Plugin.Pl.Optimize import           Plugin.Pl.Parser import           Plugin.Pl.PrettyPrinter import           Plugin.Pl.Transform--import           Data.Char               (isSpace)- import           System.Environment      (getArgs) import           System.Exit             (exitFailure) import           System.IO               (BufferMode (NoBuffering),                                           hSetBuffering, stdout)+import           Test.HUnit+import           Test.QuickCheck  instance Arbitrary Expr where-  arbitrary = sized $ \size -> frequency $ zipWith (,) [1,size,size]+  arbitrary = sized $ \size -> frequency $ zip [1,size,size]     [arbVar,      liftM2 Lambda arbitrary arbitrary,      let se = resize (size `div` 2) arbitrary in liftM2 App se se ]    shrink (Var _ _) = []   shrink (Lambda v e) =-    e : map (\v' -> Lambda v' e) (shrink v) ++ map (Lambda v) (shrink e)+    e : map (`Lambda` e) (shrink v) ++ map (Lambda v) (shrink e)   shrink (App e1 e2) = [e1, e2] ++     map (App e1) (shrink e2) ++ map (`App` e2) (shrink e1)   -- Let isn't generated by arbitrary, so we can probably ignore it-  shrink (Let{}) = error "Expr.shrink: Let"+  shrink Let{} = error "Expr.shrink: Let"  instance Arbitrary Pattern where   arbitrary = sized $ \size ->     let       spat = resize (size `div` 5) arbitrary     in-      frequency $ zipWith (,) [1,size,size] [+      frequency $ zip [1,size,size] [         (PVar . return) `fmap` choose ('a','z'),         liftM2 PTuple spat spat,         liftM2 PCons  spat spat]@@ -71,10 +69,10 @@     print d     putStrLn "Transformed to pointfree style:"     let d' = mapTopLevel transform d-    print $ d'+    print d'     putStrLn "Optimized expression:"     mapM_ print $ mapTopLevel' optimize d'-  Left err -> putStrLn $ err+  Left err -> putStrLn err  unitTest :: String -> [String] -> Test unitTest inp out = TestCase $ do@@ -86,7 +84,7 @@     [] -> error "Test case expected result missing!"     [x] -> assertEqual (inp ++ " failed.") x res     _ -> assertBool-      (concat [inp, " failed.",+      (fold [inp, " failed.",         "\nexpected one of:\n", show out,         "\n        but got:\n", show res])       (res `elem` out)@@ -236,5 +234,4 @@ doTests = do   Counts{ errors = es, failures = fs } <- runTestTT unitTests   qcTests-  when (es > 0 || fs > 0) $ exitFailure-  return ()+  when (es > 0 || fs > 0) exitFailure