blunt 0.0.9 → 0.0.10
raw patch · 6 files changed
+660/−6 lines, 6 filesdep +haskell-srcdep +mtldep +sybdep ~containersPVP ok
version bump matches the API change (PVP)
Dependencies added: haskell-src, mtl, syb
Dependency ranges changed: containers
API changes (from Hackage documentation)
+ Blunt: pointfulAction :: Action
Files
- CHANGELOG.md +4/−0
- blunt.cabal +12/−1
- library/Blunt.hs +41/−5
- library/Lambdabot/FixPrecedence.hs +343/−0
- library/Lambdabot/Parser.hs +87/−0
- library/Lambdabot/Pointful.hs +173/−0
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Change log +## v0.0.10 (2015-03-23)++- Added a pointful conversion of the expression as well.+ ## v0.0.9 (2015-03-20) - Updated to list all intermediate steps instead of only the final result.
blunt.cabal view
@@ -1,5 +1,5 @@ name: blunt-version: 0.0.9+version: 0.0.10 cabal-version: >=1.10 build-type: Simple license: MIT@@ -44,6 +44,17 @@ Plugin.Pl.Optimize Plugin.Pl.Rules Plugin.Pl.Transform++ -- pointful+ build-depends:+ containers -any,+ haskell-src -any,+ mtl -any,+ syb -any+ other-modules:+ Lambdabot.FixPrecedence+ Lambdabot.Parser+ Lambdabot.Pointful executable blunt main-is: Main.hs
library/Blunt.hs view
@@ -6,6 +6,7 @@ import Data.ByteString.Char8 (unpack) import Data.ByteString.Lazy (fromStrict) import Data.ByteString.Lazy.Char8 (pack)+import Lambdabot.Pointful (pointful) import Network.HTTP.Types (notFound404, ok200) import Network.Wai (Application, Request, Response, queryString, pathInfo, requestMethod, responseLBS)@@ -27,6 +28,7 @@ route request = case (requestMethod request, pathInfo request) of ("GET", []) -> indexAction ("GET", ["pointfree"]) -> pointfreeAction+ ("GET", ["pointful"]) -> pointfulAction _ -> notFoundAction indexAction :: Action@@ -48,6 +50,17 @@ else pack (unlines output) return (responseLBS ok200 headers body) +pointfulAction :: Action+pointfulAction request = do+ let params = queryString request+ input = case lookup "input" params of+ Just (Just param) -> param+ _ -> ""+ output = pointful (unpack input)+ let headers = [("Content-Type", "text/plain; charset=utf-8")]+ body = pack output+ return (responseLBS ok200 headers body)+ notFoundAction :: Action notFoundAction _request = return (responseLBS notFound404 [] "") @@ -81,10 +94,15 @@ , " <input id='input' placeholder='sum xs = foldr (+) 0 xs' autocapitalize='none' autocomplete='off' autocorrect='off' autofocus spellcheck='false'>" , " </dd>" , ""- , " <dt>Output</dt>"+ , " <dt>Pointfree</dt>" , " <dd>"- , " <div id='output'></div>"+ , " <div id='pointfree'></div>" , " </dd>"+ , ""+ , " <dt>Pointful</dt>"+ , " <dd>"+ , " <div id='pointful'></div>"+ , " </dd>" , " </dl>" , "" , " <p>"@@ -169,18 +187,36 @@ , "" , "(function () {" , " var input = document.getElementById('input');"- , " var output = document.getElementById('output');"+ , " var pointfree = document.getElementById('pointfree');"+ , " var pointful = document.getElementById('pointful');" , ""- , " input.oninput = function (_event) {"+ , " var updatePointfree = function () {" , " var request = new XMLHttpRequest();" , "" , " request.onreadystatechange = function () {" , " if (request.readyState === 4 && request.status === 200) {"- , " output.textContent = request.response;"+ , " pointfree.textContent = request.response;" , " }" , " };" , " request.open('GET', '/pointfree?input=' + encodeURIComponent(input.value));" , " request.send();"+ , " };"+ , ""+ , " var updatePointful = function () {"+ , " var request = new XMLHttpRequest();"+ , ""+ , " request.onreadystatechange = function () {"+ , " if (request.readyState === 4 && request.status === 200) {"+ , " pointful.textContent = request.response;"+ , " }"+ , " };"+ , " request.open('GET', '/pointful?input=' + encodeURIComponent(input.value));"+ , " request.send();"+ , " };"+ , ""+ , " input.oninput = function (_event) {"+ , " updatePointfree();"+ , " updatePointful();" , " };" , "}());" ]
+ library/Lambdabot/FixPrecedence.hs view
@@ -0,0 +1,343 @@+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+
+ library/Lambdabot/Parser.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE Rank2Types #-}++-- 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++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++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++prettyPrintInLine :: Pretty a => a -> String+prettyPrintInLine = prettyPrintWithMode (defaultMode { layout = PPInLine })
+ library/Lambdabot/Pointful.hs view
@@ -0,0 +1,173 @@+{-# OPTIONS -fno-warn-missing-signatures #-}+module Lambdabot.Pointful (pointful, ParseResult(..), test, main, combinatorModule) where++import Lambdabot.Parser++import Control.Monad.State+import Data.Generics+import Data.Maybe+import Language.Haskell.Parser+import Language.Haskell.Syntax+import qualified Data.Map as M++---- Utilities ----++extT' :: (Typeable a, Typeable b) => (a -> a) -> (b -> b) -> a -> a+extT' = extT+infixl `extT'`++unkLoc = SrcLoc "<new>" 1 1++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++succName (HsIdent s) = HsIdent . reverse . succAlpha . reverse $ s++succAlpha ('z':xs) = 'a' : succAlpha xs+succAlpha (x :xs) = succ x : xs+succAlpha [] = "a"++---- 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) []]+---- combine function binding and lambda+optimizeD (HsFunBind [HsMatch loc fname pats1 (HsUnGuardedRhs (HsLambda _ pats2 rhs)) []])+ = HsFunBind [HsMatch loc fname (pats1 ++ pats2) (HsUnGuardedRhs rhs) []]+optimizeD x = x++-- remove parens+optimizeRhs (HsUnGuardedRhs (HsParen x))+ = HsUnGuardedRhs x+optimizeRhs x = x++optimizeE :: HsExp -> HsExp+-- 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+-- apply ((\_ z -> ...) y) yielding (\z -> ...)+optimizeE (HsApp (HsParen (HsLambda loc (HsPWildCard : pats) body)) _)+ = HsParen (HsLambda loc pats body)+-- remove 0-arg lambdas resulting from application rules+optimizeE (HsLambda _ [] b)+ = b+-- replace (\x -> \y -> z) with (\x y -> z)+optimizeE (HsLambda loc p1 (HsLambda _ p2 body))+ = HsLambda loc (p1 ++ p2) body+-- remove double parens+optimizeE (HsParen (HsParen x))+ = HsParen x+-- remove lambda body parens+optimizeE (HsLambda l p (HsParen x))+ = HsLambda l p x+-- remove var, lit parens+optimizeE (HsParen x@(HsVar _))+ = x+optimizeE (HsParen x@(HsLit _))+ = x+-- remove infix+lambda parens+optimizeE (HsInfixApp a o (HsParen l@(HsLambda _ _ _)))+ = HsInfixApp a o l+-- remove left-assoc application parens+optimizeE (HsApp (HsParen (HsApp a b)) c)+ = HsApp (HsApp a b) c+-- restore infix+optimizeE (HsApp (HsApp (HsVar name@(UnQual (HsSymbol _))) l) r)+ = (HsInfixApp l (HsQVarOp name) r)+-- fail+optimizeE x = x++---- Decombinatorization ----++-- fresh name generation. TODO: prettify this+fresh = do (_, used) <- get+ modify (\(v,u) -> (until (not . (`elem` used)) succName (succName v), u))+ (name, _) <- get+ return name++-- rename all lambda-bound variables. TODO: rewrite lets as well+rename = do everywhereM (mkM (\e -> case e of+ (HsLambda _ 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++-- expand plain combinators+uncomb' (HsVar qname) | isJust maybeDef = rename (fromJust maybeDef)+ where maybeDef = M.lookup qname combinators++-- eliminate sections+uncomb' (HsRightSection op arg)+ = do a <- fresh+ return (HsParen (HsLambda unkLoc [HsPVar a] (HsInfixApp (HsVar (UnQual a)) op arg)))+uncomb' (HsLeftSection arg op)+ = do a <- fresh+ return (HsParen (HsLambda unkLoc [HsPVar a] (HsInfixApp arg op (HsVar (UnQual a)))))+-- infix to prefix for canonicality+uncomb' (HsInfixApp lf (HsQVarOp name) rf)+ = return (HsParen (HsApp (HsApp (HsVar name) (HsParen lf)) (HsParen rf)))++-- fail+uncomb' expr = return expr++---- Simple combinator definitions ---++combinators = M.fromList $ map declToTuple defs+ where defs = case parseModule combinatorModule of+ ParseOk (HsModule _ _ _ _ d) -> d+ f@(ParseFailed _ _) -> error ("Combinator loading: " ++ show f)+ declToTuple (HsPatBind _ (HsPVar fname) (HsUnGuardedRhs body) [])+ = (UnQual fname, HsParen body)++-- 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 = map (\(UnQual n) -> n) $ M.keys combinators++combinatorModule = unlines [+ "(.) = \\f g x -> f (g x) ",+ "($) = \\f x -> f x ",+ "flip = \\f x y -> f y x ",+ "const = \\x _ -> x ",+ "id = \\x -> x ",+ "(=<<) = flip (>>=) ",+ "liftM2 = \\f m1 m2 -> m1 >>= \\x1 -> m2 >>= \\x2 -> return (f x1 x2) ",+ "join = (>>= id) ",+ "ap = liftM2 id ",+ " ",+ "-- ASSUMED reader monad ",+ "-- (>>=) = (\\f k r -> k (f r) r) ",+ "-- return = const ",+ ""]++---- Top level ----++uncombOnce :: (Data a) => a -> a+uncombOnce x = evalState (everywhereM (mkM uncomb') x) (HsIdent "`", namesIn x ++ recognizedNames)+uncomb :: (Eq a, Data a) => a -> a+uncomb = stabilize uncombOnce++optimizeOnce :: (Data a) => a -> a+optimizeOnce x = everywhere (mkT optimizeD `extT'` optimizeRhs `extT'` optimizeE) x+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' .) . (==))) =<<)"