blunt 0.0.10 → 0.0.11
raw patch · 7 files changed
+25/−621 lines, 7 filesdep +pointfuldep −haskell-srcdep −mtldep −sybdep ~containersPVP ok
version bump matches the API change (PVP)
Dependencies added: pointful
Dependencies removed: haskell-src, mtl, syb
Dependency ranges changed: containers
API changes (from Hackage documentation)
Files
- CHANGELOG.md +6/−0
- README.md +7/−6
- blunt.cabal +2/−12
- library/Blunt.hs +10/−0
- library/Lambdabot/FixPrecedence.hs +0/−343
- library/Lambdabot/Parser.hs +0/−87
- library/Lambdabot/Pointful.hs +0/−173
CHANGELOG.md view
@@ -1,5 +1,11 @@ # Change log +## v0.0.11 (2015-03-23)++- Added permalinks by storing the input in the URL hash and reading it on+ page load.+- Added dependency on Hackage version of pointful package.+ ## v0.0.10 (2015-03-23) - Added a pointful conversion of the expression as well.
README.md view
@@ -5,7 +5,7 @@ </h1> <p align="center">- Blunt makes Haskell expressions pointfree.+ Blunt converts between pointfree and pointful Haskell expressions. </p> <p align="center">@@ -19,9 +19,9 @@ <hr> -Blunt is a web front end to the [pointfree][] library. While you can install-and run it locally, there's no real reason to prefer it over the `pointfree`-executable. Instead, use the hosted version on Heroku:+Blunt is a web front end to the [pointfree][] and [pointful][] libraries. While+you can install and run it locally, there's no real reason to prefer it over+the `pointfree` and `pointful` executables. Instead, use the hosted version: <https://evening-thicket-5270.herokuapp.com>. ## Install@@ -36,6 +36,7 @@ ``` sh $ blunt # http://localhost:8080+ $ env PORT=8888 blunt # http://localhost:8888 ```@@ -45,6 +46,7 @@ ``` sh $ git clone https://github.com/tfausak/blunt $ cd blunt+ $ cabal sandbox init $ cabal install happy $ cabal install@@ -61,8 +63,7 @@ $ git add package.json Procfile blunt $ git commit --allow-empty-message --message '' $ git push --force heroku deploy:master-$ git checkout master-$ git branch -D deploy ``` [pointfree]: http://hackage.haskell.org/package/pointfree+[pointful]: http://hackage.haskell.org/package/pointful
blunt.cabal view
@@ -1,5 +1,5 @@ name: blunt-version: 0.0.10+version: 0.0.11 cabal-version: >=1.10 build-type: Simple license: MIT@@ -24,6 +24,7 @@ base ==4.*, bytestring -any, http-types -any,+ pointful >=1.0.6 && <2, wai -any, warp ==3.* default-language: Haskell2010@@ -44,17 +45,6 @@ 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
@@ -190,6 +190,10 @@ , " var pointfree = document.getElementById('pointfree');" , " var pointful = document.getElementById('pointful');" , ""+ , " var updateHash = function () {"+ , " window.location.replace('#input=' + input.value);"+ , " };"+ , "" , " var updatePointfree = function () {" , " var request = new XMLHttpRequest();" , ""@@ -215,8 +219,14 @@ , " };" , "" , " input.oninput = function (_event) {"+ , " updateHash();" , " updatePointfree();" , " updatePointful();" , " };"+ , ""+ , " if (window.location.hash.indexOf('#input=') === 0) {"+ , " input.value = window.location.hash.substring(7);"+ , " input.oninput();"+ , " }" , "}());" ]
− library/Lambdabot/FixPrecedence.hs
@@ -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-
− library/Lambdabot/Parser.hs
@@ -1,87 +0,0 @@-{-# 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
@@ -1,173 +0,0 @@-{-# 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' .) . (==))) =<<)"