diff --git a/Lambdabot/FixPrecedence.hs b/Lambdabot/FixPrecedence.hs deleted file mode 100644 --- a/Lambdabot/FixPrecedence.hs +++ /dev/null @@ -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 - diff --git a/Lambdabot/Parser.hs b/Lambdabot/Parser.hs --- a/Lambdabot/Parser.hs +++ b/Lambdabot/Parser.hs @@ -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 }) diff --git a/Lambdabot/Pointful.hs b/Lambdabot/Pointful.hs --- a/Lambdabot/Pointful.hs +++ b/Lambdabot/Pointful.hs @@ -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 "" 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)) diff --git a/pointful.cabal b/pointful.cabal --- a/pointful.cabal +++ b/pointful.cabal @@ -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 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