diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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.
diff --git a/blunt.cabal b/blunt.cabal
--- a/blunt.cabal
+++ b/blunt.cabal
@@ -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
diff --git a/library/Blunt.hs b/library/Blunt.hs
--- a/library/Blunt.hs
+++ b/library/Blunt.hs
@@ -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();"
     , "  };"
     , "}());"
     ]
diff --git a/library/Lambdabot/FixPrecedence.hs b/library/Lambdabot/FixPrecedence.hs
new file mode 100644
--- /dev/null
+++ b/library/Lambdabot/FixPrecedence.hs
@@ -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
+
diff --git a/library/Lambdabot/Parser.hs b/library/Lambdabot/Parser.hs
new file mode 100644
--- /dev/null
+++ b/library/Lambdabot/Parser.hs
@@ -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 })
diff --git a/library/Lambdabot/Pointful.hs b/library/Lambdabot/Pointful.hs
new file mode 100644
--- /dev/null
+++ b/library/Lambdabot/Pointful.hs
@@ -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' .) . (==))) =<<)"