pointful 1.0.5 → 1.0.6

raw patch · 4 files changed

+125/−498 lines, 4 filesdep +haskell-src-extsdep +transformersdep −haskell-srcdep ~basedep ~containersdep ~mtlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: haskell-src-exts, transformers

Dependencies removed: haskell-src

Dependency ranges changed: base, containers, mtl, syb

API changes (from Hackage documentation)

Files

• Lambdabot/FixPrecedence.hs +0/−343
• Lambdabot/Parser.hs +13/−76
• Lambdabot/Pointful.hs +96/−63
• pointful.cabal +16/−16

@@ -1,343 +0,0 @@-module Lambdabot.FixPrecedence (withPrecExp, withPrecDecl, precTable, FixPrecedence(..) ) where--import qualified Data.Map as M-import Language.Haskell.Syntax-import Data.List--{--    PrecedenceData--    This is a data type to hold precedence information.  It simply records,-    for each operator, its precedence level (a number), and associativity-    (one of HsAssocNone, HsAssocLeft, or HsAssocRight).--}-type PrecedenceData = M.Map HsQName (HsAssoc, Int)--{--    findPrec--    Looks up precedence information for a goven operator.  If the operator-    is not in the precedence data, the Haskell report specifies that it-    should be treated as infixl 9.--}-findPrec :: PrecedenceData -> HsQName -> (HsAssoc, Int)-findPrec = flip (M.findWithDefault defaultPrec)-    where defaultPrec = (HsAssocLeft, 9)--{--    precWrong--    This returns True iff the first operator should be a parent of the-    second in the expression tree, when they occur consecutively left to-    right in the input.  This is called "wrong" because the parser in-    Language.Haskell.Parser treats everything as left associative at the-    same precedence, so the right-most operator will be the parent in the-    expression tree in the original input.--    XXX: Currently, this function treats operators with no associativity-         as if they were left associative.  It also looks only at the-         associativity of the left-most operator.  This should work for-         correct code, but it does not report errors for incorrect code.--}-precWrong :: PrecedenceData -> HsQName -> HsQName -> Bool-precWrong pd a b = let (assoc, prec) = findPrec pd a-                       (_, prec')    = findPrec pd b-                   in     (prec < prec')-                       || (prec == prec' && assoc == HsAssocRight)--{--    nameFromQOp--    Extracts the HsQName from an HsQOp.--}-nameFromQOp :: HsQOp -> HsQName-nameFromQOp (HsQVarOp s) = s-nameFromQOp (HsQConOp s) = s--nameFromOp :: HsOp -> HsQName-nameFromOp (HsVarOp n) = UnQual n-nameFromOp (HsConOp n) = UnQual n--{--    withPrecExp--    This routine fixes up an expression by applying precedence data.--}-withPrecExp :: PrecedenceData -> HsExp -> HsExp--{--    This is the heart of the whole thing.  It applies an algorithm-    described by LaLonde and Rivieres in ACM Transactions on Programming-    Languages and Systems, January 1981.  The idea is to take a parse-    tree with a consistent left-associative organization, and rearrange it-    to match a precedence table.--    A few changes have been made.  LaLonde and Rivieres remove parentheses-    from their parse tree, which isn't necessary here; and they work with-    an inherently right-associative grammar, while Language.Haskell.Parser-    produces a left-associative grammar.--}-withPrecExp pd (HsInfixApp k@(HsInfixApp e qop' f) qop g) =-    let g'  = withPrecExp pd g-        op  = nameFromQOp qop-        op' = nameFromQOp qop'-    in  if precWrong pd op' op-        then let e' = withPrecExp pd e-                 f' = withPrecExp pd f-             in  withPrecExp pd (HsInfixApp e' qop' (HsInfixApp f' qop g'))-        else HsInfixApp (withPrecExp pd k) qop g'--withPrecExp pd (HsInfixApp e op f) =-    HsInfixApp (withPrecExp pd e) op (withPrecExp pd f)--{--    The remaining cases simply propogate the correction throughout other-    elements of the grammar.--}-withPrecExp _  (HsVar v)                = HsVar v-withPrecExp _  (HsCon c)                = HsCon c-withPrecExp _  (HsLit l)                = HsLit l-withPrecExp pd (HsApp e f)              =-    HsApp (withPrecExp pd e) (withPrecExp pd f)-withPrecExp pd (HsNegApp e)             =-    HsNegApp (withPrecExp pd e)-withPrecExp pd (HsLambda loc pats e)    =-    let pats' = map (withPrecPat pd) pats-    in  HsLambda loc pats' (withPrecExp pd e)-withPrecExp pd (HsLet decls e)          =-    let (pd', decls') = mapAccumL withPrecDecl pd decls-    in  HsLet decls' (withPrecExp pd' e)-withPrecExp pd (HsIf e f g)             =-    HsIf (withPrecExp pd e) (withPrecExp pd f) (withPrecExp pd g)-withPrecExp pd (HsCase e alts)          =-    let alts' = map (withPrecAlt pd) alts-    in  HsCase (withPrecExp pd e) alts'-withPrecExp pd (HsDo stmts)             =-    let (_, stmts') = mapAccumL withPrecStmt pd stmts-    in  HsDo stmts'-withPrecExp pd (HsTuple exps)           =-    let exps' = map (withPrecExp pd) exps-    in  HsTuple exps'-withPrecExp pd (HsList exps)            =-    let exps' = map (withPrecExp pd) exps-    in  HsList exps'-withPrecExp pd (HsParen e)              =-    HsParen (withPrecExp pd e)-withPrecExp pd (HsLeftSection e op)     =-    HsLeftSection (withPrecExp pd e) op-withPrecExp pd (HsRightSection op e)    =-    HsRightSection op (withPrecExp pd e)-withPrecExp pd (HsRecConstr n upd)      =-    let upd' = map (withPrecUpd pd) upd-    in  HsRecConstr n upd'-withPrecExp pd (HsRecUpdate e upd)      =-    let upd' = map (withPrecUpd pd) upd-    in  HsRecUpdate (withPrecExp pd e) upd'-withPrecExp pd (HsEnumFrom e)           =-    HsEnumFrom (withPrecExp pd e)-withPrecExp pd (HsEnumFromThen e f)     =-    HsEnumFromThen (withPrecExp pd e) (withPrecExp pd f)-withPrecExp pd (HsEnumFromTo e f)       =-    HsEnumFromTo (withPrecExp pd e) (withPrecExp pd f)-withPrecExp pd (HsEnumFromThenTo e f g) =-    HsEnumFromThenTo (withPrecExp pd e) (withPrecExp pd f) (withPrecExp pd g)-withPrecExp pd (HsListComp e stmts)     =-    let (_, stmts') = mapAccumL withPrecStmt pd stmts-    in  HsListComp (withPrecExp pd e) stmts'-withPrecExp pd (HsExpTypeSig l e t)     =-    HsExpTypeSig l (withPrecExp pd e) t-withPrecExp pd (HsAsPat n e)            =-    HsAsPat n (withPrecExp pd e)-withPrecExp _  (HsWildCard)             =-    HsWildCard-withPrecExp pd (HsIrrPat e)             =-    HsIrrPat (withPrecExp pd e)--{--    This function is analogous to withPrec, but operates on patterns instead-    of expressions.--}-withPrecPat :: PrecedenceData -> HsPat -> HsPat--{--    This is the same algorithm based on Lalonde and Rivieres, but designed-    to work with infix data constructors in pattern matching.--}-withPrecPat pd (HsPInfixApp k@(HsPInfixApp e op' f) op g) =-    let g' = withPrecPat pd g-    in  if precWrong pd op' op-        then let e' = withPrecPat pd e-                 f' = withPrecPat pd f-             in  withPrecPat pd (HsPInfixApp e' op' (HsPInfixApp f' op g'))-        else HsPInfixApp (withPrecPat pd k) op g'--withPrecPat pd (HsPInfixApp e op f) =-    HsPInfixApp (withPrecPat pd e) op (withPrecPat pd f)--withPrecPat _  (HsPVar n)           = HsPVar n-withPrecPat _  (HsPLit l)           = HsPLit l-withPrecPat pd (HsPNeg p)           = HsPNeg (withPrecPat pd p)-withPrecPat pd (HsPApp n ps)        = let ps' = map (withPrecPat pd) ps-                                      in  HsPApp n ps'-withPrecPat pd (HsPTuple ps)        = let ps' = map (withPrecPat pd) ps-                                      in  HsPTuple ps'-withPrecPat pd (HsPList ps)         = let ps' = map (withPrecPat pd) ps-                                      in  HsPList ps'-withPrecPat pd (HsPParen p)         = HsPParen (withPrecPat pd p)-withPrecPat pd (HsPRec n pfs)       = let pfs' = map (withPrecPatField pd) pfs-                                      in  HsPRec n pfs'-withPrecPat pd (HsPAsPat n p)       = HsPAsPat n (withPrecPat pd p)-withPrecPat _  (HsPWildCard)        = HsPWildCard-withPrecPat pd (HsPIrrPat p)        = HsPIrrPat (withPrecPat pd p)--{--    Propogates precedence fixing through a pattern "field"--}-withPrecPatField :: PrecedenceData -> HsPatField -> HsPatField-withPrecPatField pd (HsPFieldPat n p) = HsPFieldPat n (withPrecPat pd p)--{--    Propogates precedence fixing through declaration sections.  This-    gets interesting, because declarations can actually change the-    existing precedence, so withPrecDecl returns both the transformed-    tree and an augmented precedence relation.--}-withPrecDecl :: PrecedenceData -> HsDecl -> (PrecedenceData, HsDecl)-withPrecDecl pd d@(HsInfixDecl _ assoc p ops)  =-    let nms      = map nameFromOp ops-        prec     = (assoc, p)-        pd'      = M.union pd $ M.fromList $ map (flip (,) prec) nms-    in  (pd', d)-withPrecDecl pd (HsClassDecl l ctx n ns decls) =-    let (pd', decls') = mapAccumL withPrecDecl pd decls-    in  (pd', HsClassDecl l ctx n ns decls')-withPrecDecl pd (HsInstDecl l ctx n ts decls)  =-    -- The question of what to do with fixity declarations here is-    -- interesting.  The report says they aren't allowed (4.3.2), but-    -- GHC accepts them as of version 6.6 and apparently ignores them.-    -- The best thing is probably to match GHC's behavior.-    let decls' = map snd $ map (withPrecDecl pd) decls-    in  (pd, HsInstDecl l ctx n ts decls')-withPrecDecl pd (HsFunBind ms)                 =-    let ms' = map (withPrecMatch pd) ms-    in  (pd, HsFunBind ms')-withPrecDecl pd (HsPatBind l p rhs decls)      =-    let p'     = withPrecPat pd p-        (pd',decls') = mapAccumL withPrecDecl pd decls-        rhs'   = withPrecRhs pd' rhs-    in  (pd, HsPatBind l p' rhs' decls')-withPrecDecl pd d                              = (pd, d)--{--    Propogates precedence fixing through HsMatch--}-withPrecMatch :: PrecedenceData -> HsMatch -> HsMatch-withPrecMatch pd (HsMatch l n ps rhs decls)           =-    let ps'           = map (withPrecPat pd) ps-        (pd', decls') = mapAccumL withPrecDecl pd decls-        rhs'          = withPrecRhs pd' rhs-    in  HsMatch l n ps' rhs' decls'--{--    Propogates precedence fixing through HsRhs--}-withPrecRhs :: PrecedenceData -> HsRhs -> HsRhs-withPrecRhs pd (HsUnGuardedRhs e)  = HsUnGuardedRhs (withPrecExp pd e)-withPrecRhs pd (HsGuardedRhss grs) = let grs' = map (withPrecGRhs pd) grs-                                     in HsGuardedRhss grs'--withPrecGRhs :: PrecedenceData -> HsGuardedRhs -> HsGuardedRhs-withPrecGRhs pd (HsGuardedRhs l e f) =-    HsGuardedRhs l (withPrecExp pd e) (withPrecExp pd f)--{--    Propogates precedence fixing through case statement alternatives.--}-withPrecAlt :: PrecedenceData -> HsAlt -> HsAlt-withPrecAlt pd (HsAlt l p alts ds) =-    let (pd', ds') = mapAccumL withPrecDecl pd ds-    in HsAlt l (withPrecPat pd p) (withPrecGAlts pd' alts) ds'--withPrecGAlts :: PrecedenceData -> HsGuardedAlts -> HsGuardedAlts-withPrecGAlts pd (HsUnGuardedAlt e) = HsUnGuardedAlt (withPrecExp pd e)-withPrecGAlts pd (HsGuardedAlts alts) = let alts' = map (withPrecGAlt pd) alts-                                        in  HsGuardedAlts alts'--withPrecGAlt :: PrecedenceData -> HsGuardedAlt -> HsGuardedAlt-withPrecGAlt pd (HsGuardedAlt l e f) =-    HsGuardedAlt l (withPrecExp pd e) (withPrecExp pd f)--{--    Propogates precedence fixing through do blocks.  Because let statements-    can change precedence, the result is both the transformed tree and an-    augmented precedence relation, much like in withPrecDecl.--}-withPrecStmt :: PrecedenceData -> HsStmt -> (PrecedenceData, HsStmt)-withPrecStmt pd (HsGenerator l p e) =-    (pd, HsGenerator l (withPrecPat pd p) (withPrecExp pd e))-withPrecStmt pd (HsQualifier e) = (pd, HsQualifier (withPrecExp pd e))-withPrecStmt pd (HsLetStmt ds)  = let (pd', ds') = mapAccumL withPrecDecl pd ds-                                  in  (pd', HsLetStmt ds')--{--    Propogates precedence fixing through record field updates.--}-withPrecUpd :: PrecedenceData -> HsFieldUpdate -> HsFieldUpdate-withPrecUpd pd (HsFieldUpdate n e) = HsFieldUpdate n (withPrecExp pd e)--{--    This is the default precedence table used for parsing expressions.-    It is taken from the precedences of the main operators in the Haskell-    Prelude.--    XXX: It might be a good idea to search the standard library docs for-         other operators.  These are the ones listed in the Haskell Report-         section 4.  For example, one that is not included here is-         Data.Ratio.%--}-precTable :: PrecedenceData-precTable = M.fromList-    [-        (UnQual (HsSymbol "!!"),      (HsAssocLeft,  9)),-        (UnQual (HsSymbol "."),       (HsAssocRight, 9)),-        (UnQual (HsSymbol "^"),       (HsAssocRight, 8)),-        (UnQual (HsSymbol "^^"),      (HsAssocRight, 8)),-        (UnQual (HsSymbol "**"),      (HsAssocLeft,  8)),-        (UnQual (HsSymbol "*"),       (HsAssocLeft,  7)),-        (UnQual (HsSymbol "/"),       (HsAssocLeft,  7)),-        (UnQual (HsIdent  "div"),     (HsAssocLeft,  7)),-        (UnQual (HsIdent  "mod"),     (HsAssocLeft,  7)),-        (UnQual (HsIdent  "rem"),     (HsAssocLeft,  7)),-        (UnQual (HsIdent  "quot"),    (HsAssocLeft,  7)),-        (UnQual (HsSymbol "+"),       (HsAssocLeft,  6)),-        (UnQual (HsSymbol "-"),       (HsAssocLeft,  6)),-        (UnQual (HsSymbol ":"),       (HsAssocRight, 5)),-        (Special HsCons,              (HsAssocRight, 5)),-        (UnQual (HsSymbol "++"),      (HsAssocRight, 5)),-        (UnQual (HsSymbol "=="),      (HsAssocNone,  4)),-        (UnQual (HsSymbol "/="),      (HsAssocNone,  4)),-        (UnQual (HsSymbol "<"),       (HsAssocNone,  4)),-        (UnQual (HsSymbol "<="),      (HsAssocNone,  4)),-        (UnQual (HsSymbol ">"),       (HsAssocNone,  4)),-        (UnQual (HsSymbol ">="),      (HsAssocNone,  4)),-        (UnQual (HsIdent  "elem"),    (HsAssocNone,  4)),-        (UnQual (HsIdent  "notElem"), (HsAssocNone,  4)),-        (UnQual (HsSymbol "&&"),      (HsAssocRight, 3)),-        (UnQual (HsSymbol "||"),      (HsAssocRight, 2)),-        (UnQual (HsSymbol ">>"),      (HsAssocLeft,  1)),-        (UnQual (HsSymbol ">>="),     (HsAssocLeft,  1)),-        (UnQual (HsSymbol "$"),       (HsAssocRight, 0)),-        (UnQual (HsSymbol "$!"),      (HsAssocRight, 0)),-        (UnQual (HsIdent  "seq"),     (HsAssocRight, 0))-    ]---class FixPrecedence a where-    fixPrecedence :: a -> a--instance FixPrecedence HsExp where-    fixPrecedence = withPrecExp precTable--instance FixPrecedence HsDecl where-    fixPrecedence = snd . withPrecDecl precTable-

@@ -2,86 +2,23 @@  -- Haskell expression parser.  Big hack, but only uses documented APIs so it -- should be more robust than the previous hack.-module Lambdabot.Parser (parseExpr, parseDecl, withParsed, prettyPrintInLine) where+module Lambdabot.Parser+    ( withParsed+    , prettyPrintInLine+    ) where -import Control.Monad.Error () -- Monad Either instance-import Data.Char import Data.Generics-import Language.Haskell.Parser-import Language.Haskell.Pretty-import Language.Haskell.Syntax--import Lambdabot.FixPrecedence--parseExpr :: String -> Either String HsExp-parseExpr s-    | not (balanced 0 ' ' s) = Left "Unbalanced parentheses"-    | otherwise          = case parseModule wrapped of-        ParseOk (HsModule _ _ _ _ [HsPatBind _ _ (HsUnGuardedRhs e) _])-            -> Right $ fixPrecedence $ unparen e-        ParseFailed (SrcLoc _ _ col) msg-            -> Left $ showParseError msg (col - length prefix) s-  where-    prefix  = "module Main where { main = ("-    wrapped = prefix ++ s ++ "\n)}"--    unparen (HsParen e) = e-    unparen e           = e--    -- balanced (open-parentheses) (previous-character) (remaining-string)-    balanced :: Int -> Char -> String -> Bool-    balanced n _ ""           = n == 0-    balanced n _ ('(':cs)     =           balanced (n+1) '(' cs-    balanced n _ (')':cs)     = n > 0  && balanced (n-1) ')' cs-    balanced n p (c  :cs)-      | c `elem` "\"'" && (not  (isAlphaNum p) || c /= '\'')-                              =           balancedString c n cs-    balanced n p ('-':'-':_)-      | not (isSymbol p)      = n == 0-    balanced n _ ('{':'-':cs) =           balancedComment 1 n cs-    balanced n _ (c  :cs)     =           balanced n     c   cs--    balancedString :: Char -> Int -> String -> Bool-    balancedString _     n ""          = n == 0 -- the parse error will be reported by L.H.Parser-    balancedString delim n ('\\':c:cs)-      | isSpace c                      = case dropWhile isSpace cs of-                                            '\\':cs' -> balancedString delim n cs'-                                            cs'      -> balancedString delim n cs'-      | otherwise                      = balancedString delim n cs-    balancedString delim n (c     :cs)-      | delim == c                     = balanced n c cs-      | otherwise                      = balancedString delim n cs--    balancedComment :: Int -> Int -> String -> Bool-    balancedComment 0 n cs           = balanced n ' ' cs-    balancedComment _ _ ""           = True -- the parse error will be reported by L.H.Parser-    balancedComment m n ('{':'-':cs) = balancedComment (m+1) n cs-    balancedComment m n ('-':'}':cs) = balancedComment (m-1) n cs-    balancedComment m n (_      :cs) = balancedComment m     n cs---parseDecl :: String -> Either String HsDecl-parseDecl s = case parseModule s of-        ParseOk (HsModule _ _ _ _ [d])   -> Right $ fixPrecedence d-        ParseFailed (SrcLoc _ _ col) msg -> Left $ showParseError msg col s--showParseError :: String -> Int -> String -> String-showParseError msg col s = " " ++ msg-                       ++ case (col < 0, drop (col - 1) s) of-                            (True, _) -> " at end of input" -- on the next line, which has no prefix-                            (_,[]   ) -> " at end of input"-                            (_,ctx  ) -> let ctx' = takeWhile (/= ' ') ctx-                                         in " at \"" ++ (take 5 ctx')-                                         ++ (if length ctx' > 5 then "..." else "")-                                         ++ "\" (column " ++ show col ++ ")"---- Not really parsing+import Language.Haskell.Exts +-- |Parse a string as an 'Exp' or a 'Decl', apply the given generic transformation to it,+-- and re-render it back to text. withParsed :: (forall a. (Data a, Eq a) => a -> a) -> String -> String-withParsed f s = case (parseExpr s, parseDecl s) of-                    (Right a, _) -> prettyPrintInLine $ f a-                    (_, Right a) -> prettyPrintInLine $ f a-                    (Left e,  _) -> e+withParsed _ "" = "Error: expected a Haskell expression or declaration"+withParsed f s  = case (parseExp s, parseDecl s) of+    (ParseOk a, _)          -> prettyPrintInLine $ f a+    (_, ParseOk a)          -> prettyPrintInLine $ f a+    (ParseFailed l e,  _)   -> prettyPrint l ++ ':' : e +-- |Render haskell code in a compact format prettyPrintInLine :: Pretty a => a -> String prettyPrintInLine = prettyPrintWithMode (defaultMode { layout = PPInLine })

@@ -1,14 +1,15 @@ {-# OPTIONS -fno-warn-missing-signatures #-}-module Lambdabot.Pointful (pointful, ParseResult(..), test, main, combinatorModule) where+-- Undo pointfree transformations. Plugin code derived from Pl.hs.+module Lambdabot.Pointful (pointful) where -import Lambdabot.Parser+import Lambdabot.Parser (withParsed)  import Control.Monad.State+import Data.Functor.Identity (Identity) import Data.Generics-import Data.Maybe-import Language.Haskell.Parser-import Language.Haskell.Syntax import qualified Data.Map as M+import Data.Maybe+import Language.Haskell.Exts as Hs  ---- Utilities ---- @@ -16,15 +17,23 @@ extT' = extT infixl `extT'` +unkLoc :: SrcLoc unkLoc = SrcLoc "<new>" 1 1 +stabilize :: Eq a => (a -> a) -> a -> a stabilize f x = let x' = f x in if x' == x then x else stabilize f x' -namesIn h = everything (++) (mkQ [] (\x -> case x of UnQual name -> [name]; _ -> [])) h-pVarsIn h = everything (++) (mkQ [] (\x -> case x of HsPVar name -> [name]; _ -> [])) h+namesIn :: Data a => a -> [Name]+namesIn h = everything (++) (mkQ [] (\x -> case x of UnQual name' -> [name']; _ -> [])) h -succName (HsIdent s) = HsIdent . reverse . succAlpha . reverse $ s+pVarsIn :: Data a => a -> [Name]+pVarsIn h = everything (++) (mkQ [] (\x -> case x of PVar name' -> [name']; _ -> [])) h +succName :: Name -> Name+succName (Ident s) = Ident . reverse . succAlpha . reverse $ s+succName (Symbol _ ) = error "Pointful plugin error: cannot determine successor for a Symbol"++succAlpha :: String -> String succAlpha ('z':xs) = 'a' : succAlpha xs succAlpha (x  :xs) = succ x : xs succAlpha []       = "a"@@ -32,106 +41,137 @@ ---- Optimization (removing explicit lambdas) and restoration of infix ops ----  -- move lambda patterns into LHS-optimizeD (HsPatBind loc (HsPVar fname) (HsUnGuardedRhs (HsLambda _ pats rhs)) [])-        =  HsFunBind [HsMatch loc fname pats (HsUnGuardedRhs rhs) []]+optimizeD :: Decl -> Decl+optimizeD (PatBind locat (PVar fname) (UnGuardedRhs (Lambda _ pats rhs)) (BDecls []))+        =  FunBind [Match locat fname pats Nothing (UnGuardedRhs rhs) (BDecls [])] ---- combine function binding and lambda-optimizeD (HsFunBind [HsMatch loc fname pats1 (HsUnGuardedRhs (HsLambda _ pats2 rhs)) []])-        =  HsFunBind [HsMatch loc fname (pats1 ++ pats2) (HsUnGuardedRhs rhs) []]+optimizeD (FunBind [Match locat fname pats1 Nothing (UnGuardedRhs (Lambda _ pats2 rhs)) (BDecls [])])+        =  FunBind [Match locat fname (pats1 ++ pats2) Nothing (UnGuardedRhs rhs) (BDecls [])] optimizeD x = x  -- remove parens-optimizeRhs (HsUnGuardedRhs (HsParen x))-          =  HsUnGuardedRhs x+optimizeRhs :: Rhs -> Rhs+optimizeRhs (UnGuardedRhs (Paren x))+          =  UnGuardedRhs x optimizeRhs x = x -optimizeE :: HsExp -> HsExp+optimizeE :: Exp -> Exp -- apply ((\x z -> ...x...) y) yielding (\z -> ...y...) if there is only one x or y is simple-optimizeE (HsApp (HsParen (HsLambda loc (HsPVar ident : pats) body)) arg) | single || simple-        = HsParen (HsLambda loc pats (everywhere (mkT (\x -> if x == (HsVar (UnQual ident)) then arg else x)) body))-  where single = gcount (mkQ False (== ident)) body == 1-        simple = case arg of HsVar _ -> True; _ -> False+  -- TODO: avoid captures while substituting+optimizeE (App (Paren (Lambda locat (PVar ident : pats) body)) arg) | single || simple arg+        = Paren (Lambda locat pats (everywhere (mkT (\x -> if x == (Var (UnQual ident)) then arg else x)) body))+  where single = gcount (mkQ False (== ident)) body <= 1+        simple e = case e of Var _ -> True; Lit _ -> True; Paren e' -> simple e'; _ -> False -- apply ((\_ z -> ...) y) yielding (\z -> ...)-optimizeE (HsApp (HsParen (HsLambda loc (HsPWildCard : pats) body)) _)-        = HsParen (HsLambda loc pats body)+optimizeE (App (Paren (Lambda locat (PWildCard : pats) body)) _)+        = Paren (Lambda locat pats body) -- remove 0-arg lambdas resulting from application rules-optimizeE (HsLambda _ [] b)+optimizeE (Lambda _ [] b)         = b -- replace (\x -> \y -> z) with (\x y -> z)-optimizeE (HsLambda loc p1 (HsLambda _ p2 body))-        = HsLambda loc (p1 ++ p2) body+optimizeE (Lambda locat p1 (Lambda _ p2 body))+        = Lambda locat (p1 ++ p2) body -- remove double parens-optimizeE (HsParen (HsParen x))-        = HsParen x+optimizeE (Paren (Paren x))+        = Paren x -- remove lambda body parens-optimizeE (HsLambda l p (HsParen x))-        = HsLambda l p x+optimizeE (Lambda l p (Paren x))+        = Lambda l p x -- remove var, lit parens-optimizeE (HsParen x@(HsVar _))+optimizeE (Paren x@(Var _))         = x-optimizeE (HsParen x@(HsLit _))+optimizeE (Paren x@(Lit _))         = x -- remove infix+lambda parens-optimizeE (HsInfixApp a o (HsParen l@(HsLambda _ _ _)))-        = HsInfixApp a o l+optimizeE (InfixApp a o (Paren l@(Lambda _ _ _)))+        = InfixApp a o l -- remove left-assoc application parens-optimizeE (HsApp (HsParen (HsApp a b)) c)-        = HsApp (HsApp a b) c+optimizeE (App (Paren (App a b)) c)+        = App (App a b) c -- restore infix-optimizeE (HsApp (HsApp (HsVar name@(UnQual (HsSymbol _))) l) r)-        = (HsInfixApp l (HsQVarOp name) r)+optimizeE (App (App (Var name'@(UnQual (Symbol _))) l) r)+        = (InfixApp l (QVarOp name') r)+-- eta reduce+optimizeE (Lambda l ps@(_:_) (App e (Var (UnQual v))))+  | free && last ps == PVar v+        = Lambda l (init ps) e+  where free = gcount (mkQ False (== v)) e == 0 -- fail optimizeE x = x  ---- Decombinatorization ----  -- fresh name generation. TODO: prettify this+fresh :: StateT (Name, [Name]) Identity Name fresh = do (_,    used) <- get            modify (\(v,u) -> (until (not . (`elem` used)) succName (succName v), u))-           (name, _) <- get-           return name+           (name', _) <- get+           return name'  -- rename all lambda-bound variables. TODO: rewrite lets as well+rename :: Exp -> StateT (Name, [Name]) Identity  Exp rename = do everywhereM (mkM (\e -> case e of-              (HsLambda _ ps _) -> do+              (Lambda _ ps _) -> do                 let pVars = concatMap pVarsIn ps                 newVars <- mapM (const fresh) pVars                 let replacements = zip pVars newVars                 return (everywhere (mkT (\n -> fromMaybe n (lookup n replacements))) e)               _ -> return e)) -uncomb' :: HsExp -> State (HsName, [HsName]) HsExp+uncomb' :: Exp -> State (Name, [Name]) Exp +uncomb' (Paren (Paren e)) = return (Paren e)+ -- expand plain combinators-uncomb' (HsVar qname) | isJust maybeDef = rename (fromJust maybeDef)+uncomb' (Var qname) | isJust maybeDef = rename (fromJust maybeDef)   where maybeDef = M.lookup qname combinators  -- eliminate sections-uncomb' (HsRightSection op arg)+uncomb' (RightSection op' arg)   = do a <- fresh-       return (HsParen (HsLambda unkLoc [HsPVar a] (HsInfixApp (HsVar (UnQual a)) op arg)))-uncomb' (HsLeftSection arg op)+       return (Paren (Lambda unkLoc [PVar a] (InfixApp (Var (UnQual a)) op' arg)))+uncomb' (LeftSection arg op')   = do a <- fresh-       return (HsParen (HsLambda unkLoc [HsPVar a] (HsInfixApp arg op (HsVar (UnQual a)))))+       return (Paren (Lambda unkLoc [PVar a] (InfixApp arg op' (Var (UnQual a))))) -- infix to prefix for canonicality-uncomb' (HsInfixApp lf (HsQVarOp name) rf)-  = return (HsParen (HsApp (HsApp (HsVar name) (HsParen lf)) (HsParen rf)))+uncomb' (InfixApp lf (QVarOp name') rf)+  = return (Paren (App (App (Var name') (Paren lf)) (Paren rf))) +-- Expand (>>=) when it is obviously the reader monad:++-- rewrite: (>>=) (\x -> e)+-- to:      (\ a b -> a ((\ x -> e) b) b)+uncomb' (App (Var (UnQual (Symbol ">>="))) (Paren lam@Lambda{}))+  = do a <- fresh+       b <- fresh+       return (Paren (Lambda unkLoc [PVar a, PVar b]+                 (App (App (Var (UnQual a)) (Paren (App lam (Var (UnQual b))))) (Var (UnQual b)))))+-- rewrite: ((>>=) e1) (\x y -> e2)+-- to:      (\a -> (\x y -> e2) (e1 a) a)+uncomb' (App (App (Var (UnQual (Symbol ">>="))) e1) (Paren lam@(Lambda _ (_:_:_) _)))+  = do a <- fresh+       return (Paren (Lambda unkLoc [PVar a]+                (App (App lam (App e1 (Var (UnQual a)))) (Var (UnQual a)))))+ -- fail uncomb' expr = return expr  ---- Simple combinator definitions ----+combinators :: M.Map QName Exp combinators = M.fromList $ map declToTuple defs   where defs = case parseModule combinatorModule of-          ParseOk (HsModule _ _ _ _ d) -> d+          ParseOk (Hs.Module _ _ _ _ _ _ d) -> d           f@(ParseFailed _ _) -> error ("Combinator loading: " ++ show f)-        declToTuple (HsPatBind _ (HsPVar fname) (HsUnGuardedRhs body) [])-          = (UnQual fname, HsParen body)+        declToTuple (PatBind _ (PVar fname) (UnGuardedRhs body) (BDecls []))+          = (UnQual fname, Paren body)+        declToTuple _ = error "Pointful Plugin error: can't convert declaration to tuple"  -- the names we recognize as combinators, so we don't generate them as temporaries then substitute them. -- TODO: more generally correct would be to not substitute any variable which is bound by a pattern+recognizedNames :: [Name] recognizedNames = map (\(UnQual n) -> n) $ M.keys combinators +combinatorModule :: String combinatorModule = unlines [   "(.)    = \\f g x -> f (g x)                                          ",   "($)    = \\f x   -> f x                                              ",@@ -142,6 +182,8 @@   "liftM2 = \\f m1 m2 -> m1 >>= \\x1 -> m2 >>= \\x2 -> return (f x1 x2) ",   "join   = (>>= id)                                                    ",   "ap     = liftM2 id                                                   ",+  "(>=>)  = flip (<=<)                                                  ",+  "(<=<)  = \\f g x -> f >>= g x                                        ",   "                                                                     ",   "-- ASSUMED reader monad                                              ",   "-- (>>=)  = (\\f k r -> k (f r) r)                                   ",@@ -151,7 +193,7 @@ ---- Top level ----  uncombOnce :: (Data a) => a -> a-uncombOnce x = evalState (everywhereM (mkM uncomb') x) (HsIdent "`", namesIn x ++ recognizedNames)+uncombOnce x = evalState (everywhereM (mkM uncomb') x) (Ident "`", namesIn x ++ recognizedNames) uncomb :: (Eq a, Data a) => a -> a uncomb = stabilize uncombOnce @@ -160,14 +202,5 @@ optimize :: (Eq a, Data a) => a -> a optimize = stabilize optimizeOnce -pointful = withParsed (optimize . uncomb)--test s = case parseModule s of-  f@(ParseFailed _ _) -> fail (show f)-  ParseOk (HsModule _ _ _ _ defs) ->-    flip mapM_ defs $ \def -> do-      putStrLn . prettyPrintInLine  $ def-      putStrLn . prettyPrintInLine  . uncomb $ def-      putStrLn . prettyPrintInLine  . optimize . uncomb $ def--main = test "f = tail . head; g = head . tail; h = tail + tail; three = g . h . i; dontSub = (\\x -> x + x) 1; ofHead f = f . head; fm = flip mapM_ xs (\\x -> g x); po = (+1); op = (1+); g = (. f); stabilize = fix (ap . flip (ap . (flip =<< (if' .) . (==))) =<<)"+pointful :: String -> String+pointful = withParsed (stabilize (optimize . uncomb))

@@ -1,5 +1,5 @@ name:                pointful-version:             1.0.5+version:             1.0.6  synopsis:            Pointful refactoring tool @@ -9,28 +9,28 @@ category:            Development license:             BSD3 license-file:        LICENSE-author:              Thomas Jäger+author:              Thomas Jäger et al. maintainer:          Mikhail Glushenkov <mikhail.glushenkov@gmail.com> homepage:            http://github.com/23Skidoo/pointful build-type:          Simple extra-source-files:  Lambdabot/*.hs cabal-version:       >= 1.6 -Flag separateSYB-  Description: Data.Generics available in separate package.- Library     exposed-modules:     Lambdabot.Pointful-    build-depends:       containers, haskell-src, mtl-    if flag(separateSYB)-       build-Depends: base >= 4 && < 5, syb-    else-       build-Depends: base >= 3 && < 4+    other-modules:       Lambdabot.Parser+    build-depends:       base >= 4.4 && < 5,+                         containers >= 0.4,+                         haskell-src-exts >= 1.16.0,+                         mtl >= 2,+                         syb >= 0.3,+                         transformers >= 0.2 -Executable          pointful+Executable               pointful     main-is:             Pointful.hs-    build-depends:       containers, haskell-src, mtl-    if flag(separateSYB)-       build-Depends: base >= 4 && < 5, syb-    else-       build-Depends: base >= 3 && < 4+    build-depends:       base >= 4.4 && < 5,+                         containers >= 0.4,+                         haskell-src-exts >= 1.16.0,+                         mtl >= 2,+                         syb >= 0.3,+                         transformers >= 0.2