diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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.
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -5,7 +5,7 @@
- Blunt makes Haskell expressions pointfree.
+ Blunt converts between pointfree and pointful Haskell expressions.
@@ -19,9 +19,9 @@
-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:
.
## 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
diff --git a/blunt.cabal b/blunt.cabal
--- a/blunt.cabal
+++ b/blunt.cabal
@@ -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
diff --git a/library/Blunt.hs b/library/Blunt.hs
--- a/library/Blunt.hs
+++ b/library/Blunt.hs
@@ -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();"
+ , " }"
, "}());"
]
diff --git a/library/Lambdabot/FixPrecedence.hs b/library/Lambdabot/FixPrecedence.hs
deleted file mode 100644
--- a/library/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/library/Lambdabot/Parser.hs b/library/Lambdabot/Parser.hs
deleted file mode 100644
--- a/library/Lambdabot/Parser.hs
+++ /dev/null
@@ -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 })
diff --git a/library/Lambdabot/Pointful.hs b/library/Lambdabot/Pointful.hs
deleted file mode 100644
--- a/library/Lambdabot/Pointful.hs
+++ /dev/null
@@ -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 "" 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' .) . (==))) =<<)"