pointfree-fancy 1.1.1.5 → 1.1.1.6
raw patch · 8 files changed
+157/−193 lines, 8 filesdep ~basedep ~haskell-src-extsPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, haskell-src-exts
API changes (from Hackage documentation)
Files
- Plugin/Pl/Common.hs +20/−31
- Plugin/Pl/Optimize.hs +22/−24
- Plugin/Pl/Parser.hs +14/−13
- Plugin/Pl/PrettyPrinter.hs +24/−38
- Plugin/Pl/Rules.hs +44/−44
- Plugin/Pl/Transform.hs +27/−37
- pointfree-fancy.cabal +5/−6
- test/Test.hs +1/−0
Plugin/Pl/Common.hs view
@@ -1,7 +1,7 @@ module Plugin.Pl.Common ( Fixity(..), Expr(..), Pattern(..), Decl(..), TopLevel(..),- bt, sizeExpr, mapTopLevel, mapTopLevel', getExpr,- operators, reservedOps, lookupOp, lookupFix, minPrec, maxPrec,+ bt, mapTopLevel, mapTopLevel',+ lookupFix, minPrec, maxPrec, comp, flip', id', const', scomb, cons, nil, fix', if', readM, makeList, getList, Assoc(..),@@ -12,16 +12,17 @@ module GHC.Base ) where -import Data.Maybe (isJust, fromJust)-import Data.List (intersperse, minimumBy)-import qualified Data.Map as M+import Data.List (intersperse, minimumBy)+import qualified Data.Map as M+import Data.Maybe (fromJust, fromMaybe, isJust) -import Control.Monad-import Control.Arrow (first, second, (***), (&&&), (|||), (+++))+import Control.Arrow (first, second, (&&&), (***), (+++),+ (|||))+import Control.Monad -import Language.Haskell.Exts (Assoc(..))+import Language.Haskell.Exts (Assoc (..)) -import GHC.Base (assert)+import GHC.Base (assert) -- The rewrite rules can be found at the end of the file Rules.hs@@ -46,13 +47,13 @@ deriving (Eq, Ord, Show) data Pattern- = PVar String + = PVar String | PCons Pattern Pattern | PTuple Pattern Pattern deriving (Eq, Ord, Show) -data Decl = Define { - declName :: String, +data Decl = Define {+ declName :: String, declExpr :: Expr } deriving (Eq, Ord, Show) @@ -62,21 +63,14 @@ 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+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), - \e' -> TLD False $ Define foo e')-getExpr (TLD False (Define foo e)) = (e, \e' -> TLD False $ Define foo e')+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) -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"@@ -94,7 +88,7 @@ -- Modularity is a drag getList :: Expr -> ([Expr], Expr) getList (c `App` x `App` tl) | c == cons = first (x:) $ getList tl-getList e = ([],e)+getList e = ([],e) bt :: a bt = undefined@@ -122,19 +116,14 @@ ] where inf name assoc fx = (name, (assoc, fx)) -reservedOps :: [String]-reservedOps = ["->", "..", "="]- opFM :: M.Map String (Assoc (), Int)-opFM = (M.fromList $ concat operators)+opFM = M.fromList $ join 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+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
Plugin/Pl/Optimize.hs view
@@ -3,23 +3,23 @@ optimize, ) where -import Plugin.Pl.Common-import Plugin.Pl.Rules-import Plugin.Pl.PrettyPrinter (prettyExpr)+import Plugin.Pl.Common+import Plugin.Pl.PrettyPrinter (prettyExpr)+import Plugin.Pl.Rules -import Data.List (nub)+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+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' :: 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 +)@@ -46,39 +46,37 @@ optimize :: Expr -> [Expr] optimize e = result where result :: [Expr]- result = map (snd . fromJust) . takeWhile isJust . + result = map (snd . fromJust) . takeWhile isJust . iterate ((=<<) simpleStep) $ Just (sizeExpr' e, e) simpleStep :: (Size, Expr) -> Maybe (Size, Expr)- simpleStep t = do + 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) $ + new = filter (\(x,_) -> x < fst t) . map (sizeExpr' &&& id) $ snd t: chn ++ chnn case new of- [] -> Nothing+ [] -> 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' + 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+ Or rs -> (`rewrite` 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@@ -89,16 +87,16 @@ ((e1 `App`) `map` rewDeep rule e2) rew :: (?first :: Bool) => RewriteRule -> Expr -> [Expr]-rew (RR r1 r2) e = toMonadPlus $ fire r1 r2 e +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 (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+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
Plugin/Pl/Parser.hs view
@@ -1,27 +1,28 @@ module Plugin.Pl.Parser (parsePF) where -import Plugin.Pl.Common+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 (fmap (const ()) thing))+todo thing = error ("pointfree: not supported: " ++ show (void thing)) nameString :: HSE.Name a -> (Fixity, String)-nameString (HSE.Ident _ s) = (Pref, s)+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.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.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@@ -37,13 +38,13 @@ 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)+ _ -> 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.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@@ -64,7 +65,7 @@ _ -> todo expr apps :: Expr -> [HSE.Exp a] -> Expr-apps f xs = foldl (\a x -> a `App` hseToExpr x) f xs +apps = foldl (\a x -> a `App` hseToExpr x) hseToDecl :: HSE.Decl a -> Decl hseToDecl dec = case dec of@@ -87,5 +88,5 @@ 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.ParseOk d -> Right (TLD True (hseToDecl d)) HSE.ParseFailed _ err -> Left err
Plugin/Pl/PrettyPrinter.hs view
@@ -5,10 +5,10 @@ prettyTopLevel, ) where -import Plugin.Pl.Common+import Plugin.Pl.Common -import Data.Char-import Data.List (intercalate)+import Data.Char+import Data.List (intercalate) prettyDecl :: Decl -> String prettyDecl (Define f e) = f ++ " = " ++ prettyExpr e@@ -20,7 +20,7 @@ prettyExpr = show . toSExpr prettyTopLevel :: TopLevel -> String-prettyTopLevel (TLE e) = prettyExpr e+prettyTopLevel (TLE e) = prettyExpr e prettyTopLevel (TLD _ d) = prettyDecl d data SExpr@@ -38,7 +38,7 @@ {-# INLINE toSExprHead #-} toSExprHead :: String -> [Expr] -> Maybe SExpr toSExprHead hd tl- | all (==',') hd, length hd+1 == length 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@@ -57,13 +57,13 @@ toSExpr e | (ls, tl) <- getList e, tl == nil = List $ map toSExpr ls toSExpr (App e1 e2) = case e1 of- App (Var Inf v) e0 + 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)@@ -71,39 +71,39 @@ _ -> SApp (toSExpr e1) (toSExpr e2) getHead :: Expr -> Maybe (String, [Expr])-getHead (Var _ v) = Just (v, [])+getHead (Var _ v) = Just (v, []) getHead (App e1 e2) = second (e2:) `fmap` getHead e1-getHead _ = Nothing+getHead _ = Nothing instance Show SExpr where showsPrec _ (SVar v) = (getPrefName v ++)- showsPrec p (SLambda vs e) = showParen (p > minPrec) $ ('\\':) . + 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 _ (LeftSection fx e) = showParen True $ showsPrec (snd (lookupFix fx) + 1) e . (' ':) . (getInfName fx++)- showsPrec _ (RightSection fx e) = showParen True $ + 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) + showsPrec _ (Tuple es) = showParen True+ (join `id` intersperse ", " (map show es) ++)++ showsPrec _ (List es) | Just cs <- mapM ((=<<) readM . fromSVar) es = shows (cs::String)- | otherwise = ('[':) . - (concat `id` intersperse ", " (map show es) ++) . (']':)+ | 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) . (".."++) . + 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 f1 e1 . (' ':) . (getInfName fx++) . (' ':) . showsPrec f2 e2 where fixity = snd $ lookupFix fx (f1, f2) = case fst $ lookupFix fx of@@ -125,7 +125,7 @@ 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@@ -136,25 +136,11 @@ | 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+ 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--{--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--}
Plugin/Pl/Rules.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternGuards #-}@@ -224,7 +225,6 @@ crossE = Quote $ Var Inf "***" firstE = Quote $ Var Pref "first" secondE = Quote $ Var Pref "second"-interE = Quote $ Var Pref "inter" andE = Quote $ Var Pref "and" orE = Quote $ Var Pref "or" allE = Quote $ Var Pref "all"@@ -317,37 +317,37 @@ (\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)- (\f x -> f `a` x),+ a, -- id x --> x rr0 (\x -> idE `a` x)- (\x -> x),+ id, -- flip (flip x) --> x rr (\x -> flipE `a` (flipE `a` x))- (\x -> 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)- (\f -> f),+ id, -- f . id --> f- rr0 (\f -> f `c` idE)- (\f -> f),+ rr0 (`c` idE)+ id, -- const x y --> x rr0 (\x y -> constE `a` x `a` y)- (\x _ -> x),+ const, -- not (not x) --> x rr (\x -> notE `a` (notE `a` x))- (\x -> x),+ id, -- fst (x,y) --> x rr (\x y -> fstE `a` (commaE `a` x `a` y))- (\x _ -> x),+ 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))- (\x _ -> x),+ const, -- tail (x:xs) --> xs rr (\x xs -> tailE `a` (consE `a` x `a` xs)) (\_ xs -> xs),@@ -356,12 +356,12 @@ (\f x y -> f `a` x `a` y), -- uncurry (,) --> id rr (uncurryE `a` commaE)- (idE),+ 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),+ rr (curryE `a` fstE) constE, -- curry snd --> const id rr (curryE `a` sndE) (constE `a` idE), -- s f g x --> f x (g x)@@ -377,10 +377,10 @@ -- TODO: Think about map/fmap -- fmap id --> id rr (fmapE `a` idE)- (idE),+ idE, -- map id --> id rr (mapE `a` idE)- (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)),@@ -396,7 +396,7 @@ onceRewrites :: RewriteRule onceRewrites = Hard $ Or [ -- ($) --> id- rr0 (dollarE)+ rr0 dollarE idE, -- concatMap --> (=<<) rr concatMapE extE,@@ -436,7 +436,7 @@ idE, -- (=<<) f (return x) -> f x rr (\f x -> extE `a` f `a` (returnE `a` x))- (\f x -> f `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)),@@ -465,7 +465,7 @@ (\_ y -> y), -- s (const . f) g --> f rr1 (\f g -> sE `a` (constE `c` f) `a` g)- (\f _ -> f),+ const, -- s (const f) --> (.) f rr (\f -> sE `a` (constE `a` f)) (\f -> compE `a` f),@@ -474,20 +474,20 @@ (\f -> uncurryE `a` f), -- fst (join (,) x) --> x rr (\x -> fstE `a` (joinE `a` commaE `a` x))- (\x -> x),+ id, -- snd (join (,) x) --> x rr (\x -> sndE `a` (joinE `a` commaE `a` x))- (\x -> 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))- (\f -> f),+ id, -- uncurry (curry f) --> f rr (\f -> uncurryE `a` (curryE `a` f))- (\f -> f),+ id, -- (const id . f) --> const id rr (\f -> (constE `a` idE) `c` f) (\_ -> constE `a` idE),@@ -508,10 +508,10 @@ (\f -> f `a` (f `a` (fixE `a` f))), -- fix (const f) --> f rr (\f -> fixE `a` (constE `a` f))- (\f -> f),+ id, -- flip const x --> id rr (\x -> flipE `a` constE `a` x)- (\_ -> idE),+ (pure idE), -- const . f --> flip (const f) Hard $ rr (\f -> constE `c` f)@@ -525,16 +525,16 @@ 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),+ id, -- 0 * x --> 0 rr (\x -> multE `a` zeroE `a` x)- (\_ -> zeroE),+ (pure zeroE), -- 1 * x --> x rr (\x -> multE `a` oneE `a` x)- (\x -> x),+ id, -- x - x --> 0 rr (\x -> minusE `a` x `a` x)- (\_ -> zeroE),+ (pure zeroE), -- x - y + y --> x rr (\y x -> plusE `a` (minusE `a` x `a` y) `a` y) (\_ x -> x),@@ -554,16 +554,16 @@ -- flip ($) -> & rr (flipE `a` dollarE)- (ampersandE),+ ampersandE, -- fmap . const -> (<$) rr (fmapE `c` constE)- (replaceE),+ replaceE, -- flip (<$) -> ($>) Hard $ rr (flipE `a` replaceE)- (pointyE),+ pointyE, Hard onceRewrites, -- join (fmap f x) --> f =<< x@@ -576,7 +576,7 @@ rr joinE (extE `a` idE), -- join (return x) --> x rr (\x -> joinE `a` (returnE `a` x))- (\x -> 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),@@ -611,7 +611,7 @@ -- flip (.) -> (-.) rr (flipE `a` compE)- (eyeE),+ eyeE, -- (x &) -> ($ x) rr (\x -> ampersandE `a` x)@@ -678,7 +678,7 @@ (\f g x -> f `a` (g `a` x)), -- return x y --> y rr (\y x -> returnE `a` x `a` y)- (\y _ -> 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)),@@ -712,15 +712,15 @@ -- flip (=<<) --> >>= rr (flipE `a` extE)- (bindE),+ bindE, -- flip (>=>) --> <=< rr (flipE `a` fishE)- (kliesliE),+ kliesliE, -- (.) . (=<<) --> <=< rr (compE `c` extE)- (kliesliE),+ kliesliE, -- join . (g .* f) --> f >=> g Hard $@@ -746,13 +746,13 @@ -- I think we need all three of them: -- uncurry (const f) --> f . snd rr (\f -> uncurryE `a` (constE `a` f))- (\f -> f `c` sndE),+ (`c` sndE), -- uncurry const --> fst rr (uncurryE `a` constE)- (fstE),+ fstE, -- uncurry (const . f) --> f . fst rr (\f -> uncurryE `a` (constE `c` f))- (\f -> f `c` fstE),+ (`c` fstE), -- TODO is this the right place? -- [x] --> return x@@ -780,10 +780,10 @@ (\f x xs -> consE `a` (f `a` x) `a` (fmapE `a` f `a` xs)), -- map f [] --> [] rr (\f -> mapE `a` f `a` nilE)- (\_ -> nilE),+ (pure nilE), -- fmap f [] --> [] rr (\f -> fmapE `a` f `a` nilE)- (\_ -> nilE)+ (pure nilE) ], -- foldr elimination down $ Or [@@ -828,7 +828,7 @@ ], -- Complicated Transformations- CRR (collapseLists),+ CRR collapseLists, up $ Or [CRR (evalUnary unaryBuiltins), CRR (evalBinary binaryBuiltins)], up $ CRR (assoc assocOps), up $ CRR (assocL assocOps),@@ -836,7 +836,7 @@ Up (CRR (commutative commutativeOps)) $ down $ Or [CRR $ assocL assocLOps, CRR $ assocR assocROps], - Hard $ simplifies+ Hard simplifies ] `Then` Opt (up simplifies) assocLOps, assocROps, assocOps :: [String] assocLOps = ["+", "*", "&&", "||", "max", "min"]
Plugin/Pl/Transform.hs view
@@ -1,28 +1,18 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternGuards #-} 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--}+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 (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 @@ -30,33 +20,33 @@ 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 +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+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)))+ 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 @@ -68,9 +58,9 @@ 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 (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@@ -91,7 +81,7 @@ -- Infinite generator of variable names. varNames :: [String]-varNames = concatMap (flip replicateM usableChars) [1..]+varNames = flip replicateM usableChars =<< [1..] where usableChars = ['a'..'z'] @@ -105,19 +95,19 @@ -- 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 (Lambda _ exp') = names exp' names (App exp1 exp2) = names exp1 ++ names exp2-names (Let dlcs exp) = concatMap dnames dlcs ++ names exp+names (Let dlcs exp') = (dnames =<< dlcs) ++ names exp' where- dnames (Define nm exp) = nm : names exp+ dnames (Define nm exp'') = nm : names exp'' transform' :: Expr -> Expr-transform' exp = go exp+transform' exp' = go exp' where -- Explicit sharing for readability- vars = names exp+ vars = names exp' - go (Let {}) =+ go Let {} = assert False bt go (Var f v) = Var f v@@ -144,13 +134,13 @@ | otherwise = const' `App` Var f v' getRidOfV l@(Lambda pat _) = assert (not $ v `occursP` pat) $ getRidOfV $ go l- getRidOfV (Let {}) = assert False bt+ 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'+ | otherwise = const' `App` e' where fr1 = v `isFreeIn` e1 fr2 = v `isFreeIn` e2
pointfree-fancy.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.8 name: pointfree-fancy-version: 1.1.1.5+version: 1.1.1.6 license: BSD3 license-file: LICENSE maintainer: Vanessa McHale <vamchale@gmail.com>@@ -15,7 +15,6 @@ extra-source-files: ChangeLog README- test/Test.hs source-repository head type: git@@ -31,7 +30,7 @@ Plugin.Pl.Optimize Plugin.Pl.Rules Plugin.Pl.Transform- ghc-options: -W+ ghc-options: -Wall build-depends: base >=4.5 && <5.0, array >=0.3 && <0.6,@@ -48,7 +47,7 @@ Plugin.Pl.Optimize Plugin.Pl.Rules Plugin.Pl.Transform- ghc-options: -W+ ghc-options: -Wall build-depends: base >=4.3 && <5.0, array >=0.3 && <0.6,@@ -67,12 +66,12 @@ Plugin.Pl.Optimize Plugin.Pl.Rules Plugin.Pl.Transform- ghc-options: -W+ ghc-options: -Wall build-depends: array >=0.3 && <0.6, base <5, containers >=0.3 && <0.6,- haskell-src-exts >=1.18 && <1.20,+ haskell-src-exts >=1.18 && <1.21, HUnit >=1.1 && <1.7, QuickCheck >=2.1 && <2.11, transformers <0.6
test/Test.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where import Test.HUnit