blunt 0.0.16 → 0.0.17
raw patch · 11 files changed
+9/−1423 lines, 11 filesdep +pointfreedep −arraydep −containersdep −haskell-src-extsPVP ok
version bump matches the API change (PVP)
Dependencies added: pointfree
Dependencies removed: array, containers, haskell-src-exts, transformers
API changes (from Hackage documentation)
Files
- CHANGELOG.md +4/−0
- README.md +2/−6
- blunt.cabal +2/−16
- library/Blunt/Script.hs +1/−1
- library/Plugin/Pl/Common.hs +0/−144
- library/Plugin/Pl/Optimize.hs +0/−104
- library/Plugin/Pl/Parser.hs +0/−91
- library/Plugin/Pl/PrettyPrinter.hs +0/−150
- library/Plugin/Pl/Rules.hs +0/−761
- library/Plugin/Pl/Transform.hs +0/−119
- library/Pointfree.hs +0/−31
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Change log +## v0.0.17 (2015-04-11)++- Added dependency on Hackage version of pointfree package.+ ## v0.0.16 (2015-04-03) - Fixed a bug that incorrectly decoded inputs from the URL.
README.md view
@@ -9,12 +9,8 @@ </p> <p align="center">- <a href="https://hackage.haskell.org/package/blunt">- <img alt="" src="https://img.shields.io/hackage/v/blunt.svg">- </a>- <a href="http://packdeps.haskellers.com/feed?needle=blunt">- <img alt="" src="https://img.shields.io/hackage-deps/v/blunt.svg">- </a>+ <a href="https://hackage.haskell.org/package/blunt"><img alt="Version" src="https://img.shields.io/hackage/v/blunt.svg?label=version&style=flat-square"></a>+ <a href="http://packdeps.haskellers.com/feed?needle=blunt"><img alt="Dependencies" src="https://img.shields.io/hackage-deps/v/blunt.svg?label=dependencies&style=flat-square"></a> </p> <hr>
blunt.cabal view
@@ -1,5 +1,5 @@ name: blunt-version: 0.0.16+version: 0.0.17 cabal-version: >=1.10 build-type: Simple license: MIT@@ -34,6 +34,7 @@ http-types ==0.8.*, jmacro ==0.6.*, lucid ==2.*,+ pointfree >=1.1 && <2, pointful >=1.0.6 && <2, text ==1.*, wai ==3.*,@@ -45,21 +46,6 @@ default-language: Haskell2010 hs-source-dirs: library ghc-options: -Wall-- -- pointfree- build-depends:- array >=0.3 && <0.6,- containers >=0.4 && <0.6,- haskell-src-exts ==1.16.*,- transformers <0.5- other-modules:- Pointfree- Plugin.Pl.Common- Plugin.Pl.Parser- Plugin.Pl.PrettyPrinter- Plugin.Pl.Optimize- Plugin.Pl.Rules- Plugin.Pl.Transform executable blunt main-is: Main.hs
library/Blunt/Script.hs view
@@ -16,7 +16,7 @@ var pointfree = document.getElementById("pointfree"); var pointful = document.getElementById("pointful"); - var socket = new WebSocket(window.location.origin.replace('http', 'ws'));+ var socket = new WebSocket(window.location.origin.replace("http", "ws")); socket.onopen = \ { input.oninput = \ {
− library/Plugin/Pl/Common.hs
@@ -1,144 +0,0 @@-module Plugin.Pl.Common (- Fixity(..), Expr(..), Pattern(..), Decl(..), TopLevel(..),- bt, sizeExpr, mapTopLevel, mapTopLevel', getExpr,- operators, reservedOps, lookupOp, 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.Maybe (isJust, fromJust)-import Data.List (intersperse, minimumBy)-import qualified Data.Map as M--import Control.Monad-import Control.Arrow (first, second, (***), (&&&), (|||), (+++))--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) -> fmap c $ f e--getExpr :: TopLevel -> (Expr, Expr -> TopLevel)-getExpr (TLD True (Define foo e)) = (Let [Define foo e] (Var Pref foo), - \e' -> TLD False $ Define foo e')-getExpr (TLD False (Define foo e)) = (e, \e' -> TLD False $ Define foo e')-getExpr (TLE e) = (e, TLE)--sizeExpr :: Expr -> Int-sizeExpr (Var _ _) = 1-sizeExpr (App e1 e2) = sizeExpr e1 + sizeExpr e2 + 1-sizeExpr (Lambda _ e) = 1 + sizeExpr e-sizeExpr (Let ds e) = 1 + sum (map sizeDecl ds) + sizeExpr e where- sizeDecl (Define _ e') = 1 + sizeExpr e'--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))--reservedOps :: [String]-reservedOps = ["->", "..", "="]--opFM :: M.Map String (Assoc, Int)-opFM = (M.fromList $ concat operators)--lookupOp :: String -> Maybe (Assoc, Int)-lookupOp k = M.lookup k opFM--lookupFix :: String -> (Assoc, Int)-lookupFix str = case lookupOp $ str of- Nothing -> (AssocLeft, 9 + shift)- Just x -> x--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."-
− library/Plugin/Pl/Optimize.hs
@@ -1,104 +0,0 @@-{-# LANGUAGE ImplicitParams #-}-module Plugin.Pl.Optimize (- optimize,- ) where--import Plugin.Pl.Common-import Plugin.Pl.Rules-import Plugin.Pl.PrettyPrinter (prettyExpr)--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 -> (\x -> rewrite x e) =<< rs- RR {} -> rewDeep rl e- CRR {} -> rewDeep rl e- Down {} -> rewDeep rl e- - where -- rew = ...; rewDeep = ...--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 = (\x -> rew x 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
− library/Plugin/Pl/Parser.hs
@@ -1,91 +0,0 @@-module Plugin.Pl.Parser (parsePF) where--import Plugin.Pl.Common--import qualified Language.Haskell.Exts as HSE--todo :: (Show e) => e -> a-todo thing = error ("pointfree: not supported: " ++ show thing)--nameString :: HSE.Name -> (Fixity, String)-nameString (HSE.Ident s) = (Pref, s)-nameString (HSE.Symbol s) = (Inf, s)--qnameString :: HSE.QName -> (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--opString :: HSE.QOp -> (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 -> 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] -> Expr-apps f xs = foldl (\a x -> a `App` hseToExpr x) f xs --hseToDecl :: HSE.Decl -> Decl-hseToDecl dec = case dec of- HSE.PatBind _ (HSE.PVar n) (HSE.UnGuardedRhs e) (HSE.BDecls []) ->- Define (snd (nameString n)) (hseToExpr e)- HSE.FunBind [HSE.Match _ n ps Nothing (HSE.UnGuardedRhs e) (HSE.BDecls [])] ->- Define (snd (nameString n)) (foldr (\p x -> Lambda (hseToPattern p) x) (hseToExpr e) ps)- _ -> todo dec--hseToPattern :: HSE.Pat -> 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
− library/Plugin/Pl/PrettyPrinter.hs
@@ -1,150 +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 $- (concat `id` intersperse ", " (map show es) ++)- - showsPrec _ (List es) - | Just cs <- mapM ((=<<) readM . fromSVar) es = shows (cs::String)- | otherwise = ('[':) . - (concat `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 = 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--{--instance Show Assoc where- show AssocLeft = "AssocLeft"- show AssocRight = "AssocRight"- show AssocNone = "AssocNone"--instance Ord Assoc where- AssocNone <= _ = True- _ <= AssocNone = False- AssocLeft <= _ = True- _ <= AssocLeft = False- _ <= _ = True--}
− library/Plugin/Pl/Rules.hs
@@ -1,761 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleInstances #-}-{-# 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, - 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 "."-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"-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"----a, c :: MExpr -> MExpr -> MExpr-a = MApp-c e1 e2 = compE `a` e1 `a` e2-infixl 9 `a`-infixr 8 `c`---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)),- -- id x --> x- rr0 (\x -> idE `a` x)- (\x -> x),- -- flip (flip x) --> x- rr (\x -> flipE `a` (flipE `a` x))- (\x -> x),- -- 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)- (\f -> f),- -- f . id --> f- rr0 (\f -> f `c` idE)- (\f -> f),- -- const x y --> x- rr0 (\x y -> constE `a` x `a` y)- (\x _ -> x),- -- not (not x) --> x- rr (\x -> notE `a` (notE `a` x))- (\x -> x),- -- fst (x,y) --> x- rr (\x y -> fstE `a` (commaE `a` x `a` y))- (\x _ -> x),- -- 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))- (\x _ -> x),- -- 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 (=<<)- 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))- (\f x -> f `a` x),- -- (=<<) ((=<<) 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)- (\f _ -> f),- -- 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))- (\x -> x),- -- snd (join (,) x) --> x- rr (\x -> sndE `a` (joinE `a` commaE `a` x))- (\x -> x),- -- 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))- (\f -> f),- -- uncurry (curry f) --> f- rr (\f -> uncurryE `a` (curryE `a` f))- (\f -> f),- -- (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)) - (\f -> f),- -- flip const x --> id- rr (\x -> flipE `a` constE `a` x)- (\_ -> 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)- (\x -> x),- -- 0 * x --> 0- rr (\x -> multE `a` zeroE `a` x)- (\_ -> zeroE),- -- 1 * x --> x- rr (\x -> multE `a` oneE `a` x)- (\x -> x),- -- x - x --> 0- rr (\x -> minusE `a` x `a` x)- (\_ -> 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)- ],-- 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))- (\x -> x),- -- (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),- - -- (.) -> fmap- Hard $ - rr compE fmapE,-- -- 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)- (\y _ -> y),- -- 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),-- -- (=<<) 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),-- -- 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))- (\f -> f `c` sndE),- -- uncurry const --> fst- rr (uncurryE `a` constE)- (fstE),- -- uncurry (const . f) --> f . fst- rr (\f -> uncurryE `a` (constE `c` f))- (\f -> 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)- (\_ -> nilE),- -- fmap f [] --> []- rr (\f -> fmapE `a` f `a` nilE)- (\_ -> 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))- ]-
− library/Plugin/Pl/Transform.hs
@@ -1,119 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-module Plugin.Pl.Transform (- transform,- ) where--import Plugin.Pl.Common-import Plugin.Pl.PrettyPrinter ()--import qualified Data.Map as M--import Data.Graph (stronglyConnComp, flattenSCC, flattenSCCs)-import Control.Monad.Trans.State--{--nub :: Ord a => [a] -> [a]-nub = nub' S.empty where- nub' _ [] = []- nub' set (x:xs)- | x `S.member` set = nub' set xs- | otherwise = x: nub' (x `S.insert` set) xs--}--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 es = foldr1 (\x y -> Var Inf "," `App` x `App` y) es--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) = do fm <- get; return $ Var f $ maybe v id (M.lookup v fm)- 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--transform' :: Expr -> Expr-transform' (Let {}) = assert False bt-transform' (Var f v) = Var f v-transform' (App e1 e2) = App (transform' e1) (transform' e2)-transform' (Lambda (PTuple p1 p2) e) - = transform' $ Lambda (PVar "z") $ - (Lambda p1 $ Lambda p2 $ e) `App` f `App` s where- f = Var Pref "fst" `App` Var Pref "z"- s = Var Pref "snd" `App` Var Pref "z"-transform' (Lambda (PCons p1 p2) e) - = transform' $ Lambda (PVar "z") $ - (Lambda p1 $ Lambda p2 $ e) `App` f `App` s where- f = Var Pref "head" `App` Var Pref "z"- s = Var Pref "tail" `App` Var Pref "z"-transform' (Lambda (PVar v) e) = transform' $ 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 $ transform' 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- | True = const' `App` e'- where- fr1 = v `isFreeIn` e1- fr2 = v `isFreeIn` e2
− library/Pointfree.hs
@@ -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