diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,9 @@
# Change log
+## v0.0.17 (2015-04-11)
+
+- Added dependency on Hackage version of pointfree package.
+
## v0.0.16 (2015-04-03)
- Fixed a bug that incorrectly decoded inputs from the URL.
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -9,12 +9,8 @@
-
- 
-
-
- 
-
+ 
+ 
diff --git a/blunt.cabal b/blunt.cabal
--- a/blunt.cabal
+++ b/blunt.cabal
@@ -1,5 +1,5 @@
name: blunt
-version: 0.0.16
+version: 0.0.17
cabal-version: >=1.10
build-type: Simple
license: MIT
@@ -34,6 +34,7 @@
http-types ==0.8.*,
jmacro ==0.6.*,
lucid ==2.*,
+ pointfree >=1.1 && <2,
pointful >=1.0.6 && <2,
text ==1.*,
wai ==3.*,
@@ -45,21 +46,6 @@
default-language: Haskell2010
hs-source-dirs: library
ghc-options: -Wall
-
- -- pointfree
- build-depends:
- array >=0.3 && <0.6,
- containers >=0.4 && <0.6,
- haskell-src-exts ==1.16.*,
- transformers <0.5
- other-modules:
- Pointfree
- Plugin.Pl.Common
- Plugin.Pl.Parser
- Plugin.Pl.PrettyPrinter
- Plugin.Pl.Optimize
- Plugin.Pl.Rules
- Plugin.Pl.Transform
executable blunt
main-is: Main.hs
diff --git a/library/Blunt/Script.hs b/library/Blunt/Script.hs
--- a/library/Blunt/Script.hs
+++ b/library/Blunt/Script.hs
@@ -16,7 +16,7 @@
var pointfree = document.getElementById("pointfree");
var pointful = document.getElementById("pointful");
- var socket = new WebSocket(window.location.origin.replace('http', 'ws'));
+ var socket = new WebSocket(window.location.origin.replace("http", "ws"));
socket.onopen = \ {
input.oninput = \ {
diff --git a/library/Plugin/Pl/Common.hs b/library/Plugin/Pl/Common.hs
deleted file mode 100644
--- a/library/Plugin/Pl/Common.hs
+++ /dev/null
@@ -1,144 +0,0 @@
-module Plugin.Pl.Common (
- Fixity(..), Expr(..), Pattern(..), Decl(..), TopLevel(..),
- bt, sizeExpr, mapTopLevel, mapTopLevel', getExpr,
- operators, reservedOps, lookupOp, lookupFix, minPrec, maxPrec,
- comp, flip', id', const', scomb, cons, nil, fix', if', readM,
- makeList, getList,
- Assoc(..),
- module Data.Maybe,
- module Control.Arrow,
- module Data.List,
- module Control.Monad,
- module GHC.Base
- ) where
-
-import Data.Maybe (isJust, fromJust)
-import Data.List (intersperse, minimumBy)
-import qualified Data.Map as M
-
-import Control.Monad
-import Control.Arrow (first, second, (***), (&&&), (|||), (+++))
-
-import Language.Haskell.Exts (Assoc(..))
-
-import GHC.Base (assert)
-
-
--- The rewrite rules can be found at the end of the file Rules.hs
-
--- Not sure if passing the information if it was used as infix or prefix
--- is worth threading through the whole thing is worth the effort,
--- but it stays that way until the prettyprinting algorithm gets more
--- sophisticated.
-data Fixity = Pref | Inf deriving Show
-
-instance Eq Fixity where
- _ == _ = True
-
-instance Ord Fixity where
- compare _ _ = EQ
-
-data Expr
- = Var Fixity String
- | Lambda Pattern Expr
- | App Expr Expr
- | Let [Decl] Expr
- deriving (Eq, Ord, Show)
-
-data Pattern
- = PVar String
- | PCons Pattern Pattern
- | PTuple Pattern Pattern
- deriving (Eq, Ord, Show)
-
-data Decl = Define {
- declName :: String,
- declExpr :: Expr
-} deriving (Eq, Ord, Show)
-
-data TopLevel = TLD Bool Decl | TLE Expr deriving (Eq, Ord, Show)
-
-mapTopLevel :: (Expr -> Expr) -> TopLevel -> TopLevel
-mapTopLevel f tl = case getExpr tl of (e, c) -> c $ f e
-
-mapTopLevel' :: Functor f => (Expr -> f Expr) -> TopLevel -> f TopLevel
-mapTopLevel' f tl = case getExpr tl of (e, c) -> fmap c $ f e
-
-getExpr :: TopLevel -> (Expr, Expr -> TopLevel)
-getExpr (TLD True (Define foo e)) = (Let [Define foo e] (Var Pref foo),
- \e' -> TLD False $ Define foo e')
-getExpr (TLD False (Define foo e)) = (e, \e' -> TLD False $ Define foo e')
-getExpr (TLE e) = (e, TLE)
-
-sizeExpr :: Expr -> Int
-sizeExpr (Var _ _) = 1
-sizeExpr (App e1 e2) = sizeExpr e1 + sizeExpr e2 + 1
-sizeExpr (Lambda _ e) = 1 + sizeExpr e
-sizeExpr (Let ds e) = 1 + sum (map sizeDecl ds) + sizeExpr e where
- sizeDecl (Define _ e') = 1 + sizeExpr e'
-
-comp, flip', id', const', scomb, cons, nil, fix', if' :: Expr
-comp = Var Inf "."
-flip' = Var Pref "flip"
-id' = Var Pref "id"
-const' = Var Pref "const"
-scomb = Var Pref "ap"
-cons = Var Inf ":"
-nil = Var Pref "[]"
-fix' = Var Pref "fix"
-if' = Var Pref "if'"
-
-makeList :: [Expr] -> Expr
-makeList = foldr (\e1 e2 -> cons `App` e1 `App` e2) nil
-
--- Modularity is a drag
-getList :: Expr -> ([Expr], Expr)
-getList (c `App` x `App` tl) | c == cons = first (x:) $ getList tl
-getList e = ([],e)
-
-bt :: a
-bt = undefined
-
-shift, minPrec, maxPrec :: Int
-shift = 0
-maxPrec = shift + 10
-minPrec = 0
-
--- operator precedences are needed both for parsing and prettyprinting
-operators :: [[(String, (Assoc, Int))]]
-operators = (map . map . second . second $ (+shift))
- [[inf "." AssocRight 9, inf "!!" AssocLeft 9],
- [inf name AssocRight 8 | name <- ["^", "^^", "**"]],
- [inf name AssocLeft 7
- | name <- ["*", "/", "`quot`", "`rem`", "`div`", "`mod`", ":%", "%"]],
- [inf name AssocLeft 6 | name <- ["+", "-"]],
- [inf name AssocRight 5 | name <- [":", "++"]],
- [inf name AssocNone 4
- | name <- ["==", "/=", "<", "<=", ">=", ">", "`elem`", "`notElem`"]],
- [inf "&&" AssocRight 3],
- [inf "||" AssocRight 2],
- [inf ">>" AssocLeft 1, inf ">>=" AssocLeft 1, inf "=<<" AssocRight 1],
- [inf name AssocRight 0 | name <- ["$", "$!", "`seq`"]]
- ] where
- inf name assoc fx = (name, (assoc, fx))
-
-reservedOps :: [String]
-reservedOps = ["->", "..", "="]
-
-opFM :: M.Map String (Assoc, Int)
-opFM = (M.fromList $ concat operators)
-
-lookupOp :: String -> Maybe (Assoc, Int)
-lookupOp k = M.lookup k opFM
-
-lookupFix :: String -> (Assoc, Int)
-lookupFix str = case lookupOp $ str of
- Nothing -> (AssocLeft, 9 + shift)
- Just x -> x
-
-readM :: (Monad m, Read a) => String -> m a
-readM s = case [x | (x,t) <- reads s, ("","") <- lex t] of
- [x] -> return x
- [] -> fail "readM: No parse."
- _ -> fail "readM: Ambiguous parse."
-
diff --git a/library/Plugin/Pl/Optimize.hs b/library/Plugin/Pl/Optimize.hs
deleted file mode 100644
--- a/library/Plugin/Pl/Optimize.hs
+++ /dev/null
@@ -1,104 +0,0 @@
-{-# LANGUAGE ImplicitParams #-}
-module Plugin.Pl.Optimize (
- optimize,
- ) where
-
-import Plugin.Pl.Common
-import Plugin.Pl.Rules
-import Plugin.Pl.PrettyPrinter (prettyExpr)
-
-import Data.List (nub)
-
-cut :: [a] -> [a]
-cut = take 1
-
-toMonadPlus :: MonadPlus m => Maybe a -> m a
-toMonadPlus Nothing = mzero
-toMonadPlus (Just x)= return x
-
-type Size = Integer
--- This seems to be a better size for our purposes,
--- despite being "a little" slower because of the wasteful uglyprinting
-sizeExpr' :: Expr -> Size
-sizeExpr' e = 100 * fromIntegral (length $ prettyExpr e) + adjust e where
- -- hackish thing to favor some expressions if the length is the same:
- -- (+ x) --> (x +)
- -- x >>= f --> f =<< x
- -- f $ g x --> f (g x)
- adjust :: Expr -> Size
- adjust (Var _ str) -- Just n <- readM str = log (n*n+1) / 4
- | str == "uncurry" = -400
--- | str == "s" = 500
- | str == "flip" = 10
- | str == ">>=" = 5
- | str == "$" = 1
- | str == "subtract" = 1
- | str == "ap" = 200
- | str == "liftM2" = 101
- | str == "return" = -200
- | str == "zipWith" = -400
- | str == "const" = 0 -- -200
- | str == "fmap" = -100
- adjust (Lambda _ e') = adjust e'
- adjust (App e1 e2) = adjust e1 + adjust e2
- adjust _ = 0
-
-optimize :: Expr -> [Expr]
-optimize e = result where
- result :: [Expr]
- result = map (snd . fromJust) . takeWhile isJust .
- iterate ((=<<) simpleStep) $ Just (sizeExpr' e, e)
-
- simpleStep :: (Size, Expr) -> Maybe (Size, Expr)
- simpleStep t = do
- let chn = let ?first = True in step (snd t)
- chnn = let ?first = False in step =<< chn
- new = filter (\(x,_) -> x < fst t) . map (sizeExpr' &&& id) $
- snd t: chn ++ chnn
- case new of
- [] -> Nothing
- (new':_) -> return new'
-
-step :: (?first :: Bool) => Expr -> [Expr]
-step e = nub $ rewrite rules e
-
-rewrite :: (?first :: Bool) => RewriteRule -> Expr -> [Expr]
-rewrite rl e = case rl of
- Up r1 r2 -> let e' = cut $ rewrite r1 e
- e'' = rewrite r2 =<< e'
- in if null e'' then e' else e''
- OrElse r1 r2 -> let e' = rewrite r1 e
- in if null e' then rewrite r2 e else e'
- Then r1 r2 -> rewrite r2 =<< nub (rewrite r1 e)
- Opt r -> e: rewrite r e
- If p r -> if null (rewrite p e) then mzero else rewrite r e
- Hard r -> if ?first then rewrite r e else mzero
- Or rs -> (\x -> rewrite x e) =<< rs
- RR {} -> rewDeep rl e
- CRR {} -> rewDeep rl e
- Down {} -> rewDeep rl e
-
- where -- rew = ...; rewDeep = ...
-
-rewDeep :: (?first :: Bool) => RewriteRule -> Expr -> [Expr]
-rewDeep rule e = rew rule e `mplus` case e of
- Var _ _ -> mzero
- Lambda _ _ -> error "lambda: optimizer only works for closed expressions"
- Let _ _ -> error "let: optimizer only works for closed expressions"
- App e1 e2 -> ((`App` e2) `map` rewDeep rule e1) `mplus`
- ((e1 `App`) `map` rewDeep rule e2)
-
-rew :: (?first :: Bool) => RewriteRule -> Expr -> [Expr]
-rew (RR r1 r2) e = toMonadPlus $ fire r1 r2 e
-rew (CRR r) e = toMonadPlus $ r e
-rew (Or rs) e = (\x -> rew x e) =<< rs
-rew (Down r1 r2) e
- = if null e'' then e' else e'' where
- e' = cut $ rew r1 e
- e'' = rewDeep r2 =<< e'
-rew r@(Then {}) e = rewrite r e
-rew r@(OrElse {}) e = rewrite r e
-rew r@(Up {}) e = rewrite r e
-rew r@(Opt {}) e = rewrite r e
-rew r@(If {}) e = rewrite r e
-rew r@(Hard {}) e = rewrite r e
diff --git a/library/Plugin/Pl/Parser.hs b/library/Plugin/Pl/Parser.hs
deleted file mode 100644
--- a/library/Plugin/Pl/Parser.hs
+++ /dev/null
@@ -1,91 +0,0 @@
-module Plugin.Pl.Parser (parsePF) where
-
-import Plugin.Pl.Common
-
-import qualified Language.Haskell.Exts as HSE
-
-todo :: (Show e) => e -> a
-todo thing = error ("pointfree: not supported: " ++ show thing)
-
-nameString :: HSE.Name -> (Fixity, String)
-nameString (HSE.Ident s) = (Pref, s)
-nameString (HSE.Symbol s) = (Inf, s)
-
-qnameString :: HSE.QName -> (Fixity, String)
-qnameString (HSE.Qual m n) = fmap (HSE.prettyPrint m ++) (nameString n)
-qnameString (HSE.UnQual n) = nameString n
-qnameString (HSE.Special sc) = case sc of
- HSE.UnitCon -> (Pref, "()")
- HSE.ListCon -> (Pref, "[]")
- HSE.FunCon -> (Inf, "->")
- HSE.TupleCon HSE.Boxed n -> (Inf, replicate (n-1) ',')
- HSE.TupleCon{} -> todo sc
- HSE.Cons -> (Inf, ":")
- HSE.UnboxedSingleCon -> todo sc
-
-opString :: HSE.QOp -> (Fixity, String)
-opString (HSE.QVarOp qn) = qnameString qn
-opString (HSE.QConOp qn) = qnameString qn
-
-list :: [Expr] -> Expr
-list = foldr (\y ys -> cons `App` y `App` ys) nil
-
-hseToExpr :: HSE.Exp -> Expr
-hseToExpr expr = case expr of
- HSE.Var qn -> uncurry Var (qnameString qn)
- HSE.IPVar{} -> todo expr
- HSE.Con qn -> uncurry Var (qnameString qn)
- HSE.Lit l -> case l of
- HSE.String s -> list (map (Var Pref . show) s)
- _ -> Var Pref (HSE.prettyPrint l)
- HSE.InfixApp p op q -> apps (Var Inf (snd (opString op))) [p,q]
- HSE.App f x -> hseToExpr f `App` hseToExpr x
- HSE.NegApp e -> Var Pref "negate" `App` hseToExpr e
- HSE.Lambda _ ps e -> foldr (Lambda . hseToPattern) (hseToExpr e) ps
- HSE.Let bs e -> case bs of
- HSE.BDecls ds -> Let (map hseToDecl ds) (hseToExpr e)
- HSE.IPBinds ips -> todo ips
- HSE.If b t f -> apps if' [b,t,f]
- HSE.Case{} -> todo expr
- HSE.Do{} -> todo expr
- HSE.MDo{} -> todo expr
- HSE.Tuple HSE.Boxed es -> apps (Var Inf (replicate (length es - 1) ',')) es
- HSE.TupleSection{} -> todo expr
- HSE.List xs -> list (map hseToExpr xs)
- HSE.Paren e -> hseToExpr e
- HSE.LeftSection l op -> Var Inf (snd (opString op)) `App` hseToExpr l
- HSE.RightSection op r -> flip' `App` Var Inf (snd (opString op)) `App` hseToExpr r
- HSE.RecConstr{} -> todo expr
- HSE.RecUpdate{} -> todo expr
- HSE.EnumFrom x -> apps (Var Pref "enumFrom") [x]
- HSE.EnumFromTo x y -> apps (Var Pref "enumFromTo") [x,y]
- HSE.EnumFromThen x y -> apps (Var Pref "enumFromThen") [x,y]
- HSE.EnumFromThenTo x y z -> apps (Var Pref "enumFromThenTo") [x,y,z]
- _ -> todo expr
-
-apps :: Expr -> [HSE.Exp] -> Expr
-apps f xs = foldl (\a x -> a `App` hseToExpr x) f xs
-
-hseToDecl :: HSE.Decl -> Decl
-hseToDecl dec = case dec of
- HSE.PatBind _ (HSE.PVar n) (HSE.UnGuardedRhs e) (HSE.BDecls []) ->
- Define (snd (nameString n)) (hseToExpr e)
- HSE.FunBind [HSE.Match _ n ps Nothing (HSE.UnGuardedRhs e) (HSE.BDecls [])] ->
- Define (snd (nameString n)) (foldr (\p x -> Lambda (hseToPattern p) x) (hseToExpr e) ps)
- _ -> todo dec
-
-hseToPattern :: HSE.Pat -> Pattern
-hseToPattern pat = case pat of
- HSE.PVar n -> PVar (snd (nameString n))
- HSE.PInfixApp l (HSE.Special HSE.Cons) r -> PCons (hseToPattern l) (hseToPattern r)
- HSE.PTuple HSE.Boxed [p,q] -> PTuple (hseToPattern p) (hseToPattern q)
- HSE.PParen p -> hseToPattern p
- HSE.PWildCard -> PVar "_"
- _ -> todo pat
-
-parsePF :: String -> Either String TopLevel
-parsePF inp = case HSE.parseExp inp of
- HSE.ParseOk e -> Right (TLE (hseToExpr e))
- HSE.ParseFailed _ _ -> case HSE.parseDecl inp of
- HSE.ParseOk d -> Right (TLD True (hseToDecl d))
- HSE.ParseFailed _ err -> Left err
diff --git a/library/Plugin/Pl/PrettyPrinter.hs b/library/Plugin/Pl/PrettyPrinter.hs
deleted file mode 100644
--- a/library/Plugin/Pl/PrettyPrinter.hs
+++ /dev/null
@@ -1,150 +0,0 @@
-{-# LANGUAGE PatternGuards #-}
-module Plugin.Pl.PrettyPrinter (
- prettyDecl,
- prettyExpr,
- prettyTopLevel,
- ) where
-
-import Plugin.Pl.Common
-
-import Data.Char
-import Data.List (intercalate)
-
-prettyDecl :: Decl -> String
-prettyDecl (Define f e) = f ++ " = " ++ prettyExpr e
-
-prettyDecls :: [Decl] -> String
-prettyDecls = intercalate "; " . map prettyDecl
-
-prettyExpr :: Expr -> String
-prettyExpr = show . toSExpr
-
-prettyTopLevel :: TopLevel -> String
-prettyTopLevel (TLE e) = prettyExpr e
-prettyTopLevel (TLD _ d) = prettyDecl d
-
-data SExpr
- = SVar !String
- | SLambda ![Pattern] !SExpr
- | SLet ![Decl] !SExpr
- | SApp !SExpr !SExpr
- | SInfix !String !SExpr !SExpr
- | LeftSection !String !SExpr -- (x +)
- | RightSection !String !SExpr -- (+ x)
- | List ![SExpr]
- | Tuple ![SExpr]
- | Enum !Expr !(Maybe Expr) !(Maybe Expr)
-
-{-# INLINE toSExprHead #-}
-toSExprHead :: String -> [Expr] -> Maybe SExpr
-toSExprHead hd tl
- | all (==',') hd, length hd+1 == length tl
- = Just . Tuple . reverse $ map toSExpr tl
- | otherwise = case (hd,reverse tl) of
- ("enumFrom", [e]) -> Just $ Enum e Nothing Nothing
- ("enumFromThen", [e,e']) -> Just $ Enum e (Just e') Nothing
- ("enumFromTo", [e,e']) -> Just $ Enum e Nothing (Just e')
- ("enumFromThenTo", [e,e',e'']) -> Just $ Enum e (Just e') (Just e'')
- _ -> Nothing
-
-toSExpr :: Expr -> SExpr
-toSExpr (Var _ v) = SVar v
-toSExpr (Lambda v e) = case toSExpr e of
- (SLambda vs e') -> SLambda (v:vs) e'
- e' -> SLambda [v] e'
-toSExpr (Let ds e) = SLet ds $ toSExpr e
-toSExpr e | Just (hd,tl) <- getHead e, Just se <- toSExprHead hd tl = se
-toSExpr e | (ls, tl) <- getList e, tl == nil
- = List $ map toSExpr ls
-toSExpr (App e1 e2) = case e1 of
- App (Var Inf v) e0
- -> SInfix v (toSExpr e0) (toSExpr e2)
- Var Inf v | v /= "-"
- -> LeftSection v (toSExpr e2)
-
- Var _ "flip" | Var Inf v <- e2, v == "-" -> toSExpr $ Var Pref "subtract"
-
- App (Var _ "flip") (Var pr v)
- | v == "-" -> toSExpr $ Var Pref "subtract" `App` e2
- | v == "id" -> RightSection "$" (toSExpr e2)
- | Inf <- pr, any (/= ',') v -> RightSection v (toSExpr e2)
- _ -> SApp (toSExpr e1) (toSExpr e2)
-
-getHead :: Expr -> Maybe (String, [Expr])
-getHead (Var _ v) = Just (v, [])
-getHead (App e1 e2) = second (e2:) `fmap` getHead e1
-getHead _ = Nothing
-
-instance Show SExpr where
- showsPrec _ (SVar v) = (getPrefName v ++)
- showsPrec p (SLambda vs e) = showParen (p > minPrec) $ ('\\':) .
- foldr (.) id (intersperse (' ':) (map (prettyPrecPattern $ maxPrec+1) vs)) .
- (" -> "++) . showsPrec minPrec e
- showsPrec p (SApp e1 e2) = showParen (p > maxPrec) $
- showsPrec maxPrec e1 . (' ':) . showsPrec (maxPrec+1) e2
- showsPrec _ (LeftSection fx e) = showParen True $
- showsPrec (snd (lookupFix fx) + 1) e . (' ':) . (getInfName fx++)
- showsPrec _ (RightSection fx e) = showParen True $
- (getInfName fx++) . (' ':) . showsPrec (snd (lookupFix fx) + 1) e
- showsPrec _ (Tuple es) = showParen True $
- (concat `id` intersperse ", " (map show es) ++)
-
- showsPrec _ (List es)
- | Just cs <- mapM ((=<<) readM . fromSVar) es = shows (cs::String)
- | otherwise = ('[':) .
- (concat `id` intersperse ", " (map show es) ++) . (']':)
- where fromSVar (SVar str) = Just str
- fromSVar _ = Nothing
- showsPrec _ (Enum fr tn to) = ('[':) . showString (prettyExpr fr) .
- showsMaybe (((',':) . prettyExpr) `fmap` tn) . (".."++) .
- showsMaybe (prettyExpr `fmap` to) . (']':)
- where showsMaybe = maybe id (++)
- showsPrec _ (SLet ds e) = ("let "++) . showString (prettyDecls ds ++ " in ") . shows e
-
-
- showsPrec p (SInfix fx e1 e2) = showParen (p > fixity) $
- showsPrec f1 e1 . (' ':) . (getInfName fx++) . (' ':) .
- showsPrec f2 e2 where
- fixity = snd $ lookupFix fx
- (f1, f2) = case fst $ lookupFix fx of
- AssocRight -> (fixity+1, fixity + infixSafe e2 AssocLeft fixity)
- AssocLeft -> (fixity + infixSafe e1 AssocRight fixity, fixity+1)
- AssocNone -> (fixity+1, fixity+1)
-
- -- This is a little bit awkward, but at least seems to produce no false
- -- results anymore
- infixSafe :: SExpr -> Assoc -> Int -> Int
- infixSafe (SInfix fx'' _ _) assoc fx'
- | lookupFix fx'' == (assoc, fx') = 1
- | otherwise = 0
- infixSafe _ _ _ = 0 -- doesn't matter
-
-prettyPrecPattern :: Int -> Pattern -> ShowS
-prettyPrecPattern _ (PVar v) = showString v
-prettyPrecPattern _ (PTuple p1 p2) = showParen True $
- prettyPrecPattern 0 p1 . (", "++) . prettyPrecPattern 0 p2
-prettyPrecPattern p (PCons p1 p2) = showParen (p>5) $
- prettyPrecPattern 6 p1 . (':':) . prettyPrecPattern 5 p2
-
-isOperator :: String -> Bool
-isOperator s = s /= "()" && all (\c -> isSymbol c || isPunctuation c) s
-
-getInfName :: String -> String
-getInfName str = if isOperator str then str else "`"++str++"`"
-
-getPrefName :: String -> String
-getPrefName str = if isOperator str || ',' `elem` str then "("++str++")" else str
-
-{-
-instance Show Assoc where
- show AssocLeft = "AssocLeft"
- show AssocRight = "AssocRight"
- show AssocNone = "AssocNone"
-
-instance Ord Assoc where
- AssocNone <= _ = True
- _ <= AssocNone = False
- AssocLeft <= _ = True
- _ <= AssocLeft = False
- _ <= _ = True
--}
diff --git a/library/Plugin/Pl/Rules.hs b/library/Plugin/Pl/Rules.hs
deleted file mode 100644
--- a/library/Plugin/Pl/Rules.hs
+++ /dev/null
@@ -1,761 +0,0 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE ScopedTypeVariables #-}
---
--- | This marvellous module contributed by Thomas J\344ger
---
-module Plugin.Pl.Rules (RewriteRule(..), rules, fire) where
-
-import Plugin.Pl.Common
-
-import Data.Array
-import qualified Data.Set as S
-
-import Control.Monad.Fix (fix)
-
---import PlModule.PrettyPrinter
-
--- Next time I do somthing like this, I'll actually think about the combinator
--- language before, instead of producing something ad-hoc like this:
-data RewriteRule
- = RR Rewrite Rewrite
- | CRR (Expr -> Maybe Expr)
- | Down RewriteRule RewriteRule
- | Up RewriteRule RewriteRule
- | Or [RewriteRule]
- | OrElse RewriteRule RewriteRule
- | Then RewriteRule RewriteRule
- | Opt RewriteRule
- | If RewriteRule RewriteRule
- | Hard RewriteRule
-
--- No MLambda here because we only consider closed Terms (no alpha-renaming!).
-data MExpr
- = MApp !MExpr !MExpr
- | Hole !Int
- | Quote !Expr
- deriving Eq
-
---instance Show MExpr where
--- show = show . fromMExpr
-
-data Rewrite = Rewrite {
- holes :: MExpr,
- rid :: Int -- rlength - 1
-} --deriving Show
-
--- What are you gonna do when no recursive modules are possible?
-class RewriteC a where
- getRewrite :: a -> Rewrite
-
-instance RewriteC MExpr where
- getRewrite rule = Rewrite {
- holes = rule,
- rid = 0
- }
-
-type ExprArr = Array Int Expr
-
-myFire :: ExprArr -> MExpr -> MExpr
-myFire xs (MApp e1 e2) = MApp (myFire xs e1) (myFire xs e2)
-myFire xs (Hole h) = Quote $ xs ! h
-myFire _ me = me
-
-nub' :: Ord a => [a] -> [a]
-nub' = S.toList . S.fromList
-
-uniqueArray :: Ord v => Int -> [(Int, v)] -> Maybe (Array Int v)
-uniqueArray n lst
- | length (nub' lst) == n = Just $ array (0,n-1) lst
- | otherwise = Nothing
-
-match :: Rewrite -> Expr -> Maybe ExprArr
-match (Rewrite hl rid') e = uniqueArray rid' =<< matchWith hl e
-
-fire' :: Rewrite -> ExprArr -> MExpr
-fire' (Rewrite hl _) = (`myFire` hl)
-
-fire :: Rewrite -> Rewrite -> Expr -> Maybe Expr
-fire r1 r2 e = (fromMExpr . fire' r2) `fmap` match r1 e
-
-matchWith :: MExpr -> Expr -> Maybe [(Int, Expr)]
-matchWith (MApp e1 e2) (App e1' e2') =
- liftM2 (++) (matchWith e1 e1') (matchWith e2 e2')
-matchWith (Quote e) e' = if e == e' then Just [] else Nothing
-matchWith (Hole k) e = Just [(k,e)]
-matchWith _ _ = Nothing
-
-fromMExpr :: MExpr -> Expr
-fromMExpr (MApp e1 e2) = App (fromMExpr e1) (fromMExpr e2)
-fromMExpr (Hole _) = Var Pref "Hole" -- error "Hole in MExpr"
-fromMExpr (Quote e) = e
-
-instance RewriteC a => RewriteC (MExpr -> a) where
- getRewrite rule = Rewrite {
- holes = holes . getRewrite . rule . Hole $ pid,
- rid = pid + 1
- } where
- pid = rid $ getRewrite (bt :: a)
-
--- Yet another pointless transformation
-transformM :: Int -> MExpr -> MExpr
-transformM _ (Quote e) = constE `a` Quote e
-transformM n (Hole n') = if n == n' then idE else constE `a` Hole n'
-transformM n (Quote (Var _ ".") `MApp` e1 `MApp` e2)
- | e1 `hasHole` n && not (e2 `hasHole` n)
- = flipE `a` compE `a` e2 `c` transformM n e1
-transformM n e@(MApp e1 e2)
- | fr1 && fr2 = sE `a` transformM n e1 `a` transformM n e2
- | fr1 = flipE `a` transformM n e1 `a` e2
- | fr2, Hole n' <- e2, n' == n = e1
- | fr2 = e1 `c` transformM n e2
- | otherwise = constE `a` e
- where
- fr1 = e1 `hasHole` n
- fr2 = e2 `hasHole` n
-
-hasHole :: MExpr -> Int -> Bool
-hasHole (MApp e1 e2) n = e1 `hasHole` n || e2 `hasHole` n
-hasHole (Quote _) _ = False
-hasHole (Hole n') n = n == n'
-
---
--- haddock doesn't like n+k patterns, so rewrite them
---
-getVariants, getVariants' :: Rewrite -> [Rewrite]
-getVariants' r@(Rewrite _ 0) = [r]
-getVariants' r@(Rewrite e nk)
- | nk >= 1 = r : getVariants (Rewrite e' (nk-1))
- | otherwise = error "getVariants' : nk went negative"
- where
- e' = decHoles $ transformM 0 e
-
- decHoles (Hole n') = Hole (n'-1)
- decHoles (MApp e1 e2) = decHoles e1 `MApp` decHoles e2
- decHoles me = me
-
-getVariants = getVariants' -- r = trace (show vs) vs where vs = getVariants' r
-
-rr, rr0, rr1, rr2 :: RewriteC a => a -> a -> RewriteRule
--- use this rewrite rule and rewrite rules derived from it by iterated
--- pointless transformation
-rrList :: RewriteC a => a -> a -> [RewriteRule]
-rrList r1 r2 = zipWith RR (getVariants r1') (getVariants r2') where
- r1' = getRewrite r1
- r2' = getRewrite r2
-
-rr r1 r2 = Or $ rrList r1 r2
-rr1 r1 r2 = Or . take 2 $ rrList r1 r2
-rr2 r1 r2 = Or . take 3 $ rrList r1 r2
-
--- use only this rewrite rule
-rr0 r1 r2 = RR r1' r2' where
- r1' = getRewrite r1
- r2' = getRewrite r2
-
-down, up :: RewriteRule -> RewriteRule
-down = fix . Down
-up = fix . Up
-
-
-idE, flipE, bindE, extE, returnE, consE, appendE, nilE, foldrE, foldlE, fstE,
- sndE, dollarE, constE, uncurryE, curryE, compE, headE, tailE, sE, commaE,
- fixE, foldl1E, notE, equalsE, nequalsE, plusE, multE, zeroE, oneE, lengthE,
- sumE, productE, concatE, concatMapE, joinE, mapE, fmapE, fmapIE, subtractE,
- minusE, liftME, apE, liftM2E, seqME, zipE, zipWithE,
- crossE, firstE, secondE, andE, orE, allE, anyE :: MExpr
-idE = Quote $ Var Pref "id"
-flipE = Quote $ Var Pref "flip"
-constE = Quote $ Var Pref "const"
-compE = Quote $ Var Inf "."
-sE = Quote $ Var Pref "ap"
-fixE = Quote $ Var Pref "fix"
-bindE = Quote $ Var Inf ">>="
-extE = Quote $ Var Inf "=<<"
-returnE = Quote $ Var Pref "return"
-consE = Quote $ Var Inf ":"
-nilE = Quote $ Var Pref "[]"
-appendE = Quote $ Var Inf "++"
-foldrE = Quote $ Var Pref "foldr"
-foldlE = Quote $ Var Pref "foldl"
-fstE = Quote $ Var Pref "fst"
-sndE = Quote $ Var Pref "snd"
-dollarE = Quote $ Var Inf "$"
-uncurryE = Quote $ Var Pref "uncurry"
-curryE = Quote $ Var Pref "curry"
-headE = Quote $ Var Pref "head"
-tailE = Quote $ Var Pref "tail"
-commaE = Quote $ Var Inf ","
-foldl1E = Quote $ Var Pref "foldl1"
-equalsE = Quote $ Var Inf "=="
-nequalsE = Quote $ Var Inf "/="
-notE = Quote $ Var Pref "not"
-plusE = Quote $ Var Inf "+"
-multE = Quote $ Var Inf "*"
-zeroE = Quote $ Var Pref "0"
-oneE = Quote $ Var Pref "1"
-lengthE = Quote $ Var Pref "length"
-sumE = Quote $ Var Pref "sum"
-productE = Quote $ Var Pref "product"
-concatE = Quote $ Var Pref "concat"
-concatMapE = Quote $ Var Pref "concatMap"
-joinE = Quote $ Var Pref "join"
-mapE = Quote $ Var Pref "map"
-fmapE = Quote $ Var Pref "fmap"
-fmapIE = Quote $ Var Inf "fmap"
-subtractE = Quote $ Var Pref "subtract"
-minusE = Quote $ Var Inf "-"
-liftME = Quote $ Var Pref "liftM"
-liftM2E = Quote $ Var Pref "liftM2"
-apE = Quote $ Var Inf "ap"
-seqME = Quote $ Var Inf ">>"
-zipE = Quote $ Var Pref "zip"
-zipWithE = Quote $ Var Pref "zipWith"
-crossE = Quote $ Var Inf "***"
-firstE = Quote $ Var Pref "first"
-secondE = Quote $ Var Pref "second"
-andE = Quote $ Var Pref "and"
-orE = Quote $ Var Pref "or"
-allE = Quote $ Var Pref "all"
-anyE = Quote $ Var Pref "any"
-
-
-
-a, c :: MExpr -> MExpr -> MExpr
-a = MApp
-c e1 e2 = compE `a` e1 `a` e2
-infixl 9 `a`
-infixr 8 `c`
-
-
-collapseLists :: Expr -> Maybe Expr
-collapseLists (Var _ "++" `App` e1 `App` e2)
- | (xs,x) <- getList e1, x==nil,
- (ys,y) <- getList e2, y==nil = Just $ makeList $ xs ++ ys
-collapseLists _ = Nothing
-
-data Binary = forall a b c. (Read a, Show a, Read b, Show b, Read c, Show c) => BA (a -> b -> c)
-
-evalBinary :: [(String, Binary)] -> Expr -> Maybe Expr
-evalBinary fs (Var _ f' `App` Var _ x' `App` Var _ y')
- | Just (BA f) <- lookup f' fs = (Var Pref . show) `fmap` liftM2 f (readM x') (readM y')
-evalBinary _ _ = Nothing
-
-data Unary = forall a b. (Read a, Show a, Read b, Show b) => UA (a -> b)
-
-evalUnary :: [(String, Unary)] -> Expr -> Maybe Expr
-evalUnary fs (Var _ f' `App` Var _ x')
- | Just (UA f) <- lookup f' fs = (Var Pref . show . f) `fmap` readM x'
-evalUnary _ _ = Nothing
-
-assocR, assocL, assoc :: [String] -> Expr -> Maybe Expr
--- (f `op` g) `op` h --> f `op` (g `op` h)
-assocR ops (Var f1 op1 `App` (Var f2 op2 `App` e1 `App` e2) `App` e3)
- | op1 == op2 && op1 `elem` ops
- = Just (Var f1 op1 `App` e1 `App` (Var f2 op2 `App` e2 `App` e3))
-assocR _ _ = Nothing
-
--- f `op` (g `op` h) --> (f `op` g) `op` h
-assocL ops (Var f1 op1 `App` e1 `App` (Var f2 op2 `App` e2 `App` e3))
- | op1 == op2 && op1 `elem` ops
- = Just (Var f1 op1 `App` (Var f2 op2 `App` e1 `App` e2) `App` e3)
-assocL _ _ = Nothing
-
--- op f . op g --> op (f `op` g)
-assoc ops (Var _ "." `App` (Var f1 op1 `App` e1) `App` (Var f2 op2 `App` e2))
- | op1 == op2 && op1 `elem` ops
- = Just (Var f1 op1 `App` (Var f2 op2 `App` e1 `App` e2))
-assoc _ _ = Nothing
-
-commutative :: [String] -> Expr -> Maybe Expr
-commutative ops (Var f op `App` e1 `App` e2)
- | op `elem` ops = Just (Var f op `App` e2 `App` e1)
-commutative ops (Var _ "flip" `App` e@(Var _ op)) | op `elem` ops = Just e
-commutative _ _ = Nothing
-
--- TODO: Move rules into a file.
-{-# INLINE simplifies #-}
-simplifies :: RewriteRule
-simplifies = Or [
- -- (f . g) x --> f (g x)
- rr0 (\f g x -> (f `c` g) `a` x)
- (\f g x -> f `a` (g `a` x)),
- -- id x --> x
- rr0 (\x -> idE `a` x)
- (\x -> x),
- -- flip (flip x) --> x
- rr (\x -> flipE `a` (flipE `a` x))
- (\x -> x),
- -- flip id x . f --> flip f x
- rr0 (\f x -> (flipE `a` idE `a` x) `c` f)
- (\f x -> flipE `a` f `a` x),
- -- id . f --> f
- rr0 (\f -> idE `c` f)
- (\f -> f),
- -- f . id --> f
- rr0 (\f -> f `c` idE)
- (\f -> f),
- -- const x y --> x
- rr0 (\x y -> constE `a` x `a` y)
- (\x _ -> x),
- -- not (not x) --> x
- rr (\x -> notE `a` (notE `a` x))
- (\x -> x),
- -- fst (x,y) --> x
- rr (\x y -> fstE `a` (commaE `a` x `a` y))
- (\x _ -> x),
- -- snd (x,y) --> y
- rr (\x y -> sndE `a` (commaE `a` x `a` y))
- (\_ y -> y),
- -- head (x:xs) --> x
- rr (\x xs -> headE `a` (consE `a` x `a` xs))
- (\x _ -> x),
- -- tail (x:xs) --> xs
- rr (\x xs -> tailE `a` (consE `a` x `a` xs))
- (\_ xs -> xs),
- -- uncurry f (x,y) --> f x y
- rr1 (\f x y -> uncurryE `a` f `a` (commaE `a` x `a` y))
- (\f x y -> f `a` x `a` y),
- -- uncurry (,) --> id
- rr (uncurryE `a` commaE)
- (idE),
- -- uncurry f . s (,) g --> s f g
- rr1 (\f g -> (uncurryE `a` f) `c` (sE `a` commaE `a` g))
- (\f g -> sE `a` f `a` g),
- -- curry fst --> const
- rr (curryE `a` fstE) (constE),
- -- curry snd --> const id
- rr (curryE `a` sndE) (constE `a` idE),
- -- s f g x --> f x (g x)
- rr0 (\f g x -> sE `a` f `a` g `a` x)
- (\f g x -> f `a` x `a` (g `a` x)),
- -- flip f x y --> f y x
- rr0 (\f x y -> flipE `a` f `a` x `a` y)
- (\f x y -> f `a` y `a` x),
- -- flip (=<<) --> (>>=)
- rr0 (flipE `a` extE)
- bindE,
-
- -- TODO: Think about map/fmap
- -- fmap id --> id
- rr (fmapE `a` idE)
- (idE),
- -- map id --> id
- rr (mapE `a` idE)
- (idE),
- -- (f . g) . h --> f . (g . h)
- rr0 (\f g h -> (f `c` g) `c` h)
- (\f g h -> f `c` (g `c` h)),
- -- fmap f . fmap g -> fmap (f . g)
- rr0 (\f g -> fmapE `a` f `c` fmapE `a` g)
- (\f g -> fmapE `a` (f `c` g)),
- -- map f . map g -> map (f . g)
- rr0 (\f g -> mapE `a` f `c` mapE `a` g)
- (\f g -> mapE `a` (f `c` g))
-
- ]
-
-onceRewrites :: RewriteRule
-onceRewrites = Hard $ Or [
- -- ($) --> id
- rr0 (dollarE)
- idE,
- -- concatMap --> (=<<)
- rr concatMapE extE,
- -- concat --> join
- rr concatE joinE,
- -- liftM --> fmap
- rr liftME fmapE,
- -- map --> fmap
- rr mapE fmapE,
- -- subtract -> flip (-)
- rr subtractE
- (flipE `a` minusE)
- ]
-
--- Now we can state rewrite rules in a nice high level way
--- Rewrite rules should be as pointful as possible since the pointless variants
--- will be derived automatically.
-rules :: RewriteRule
-rules = Or [
- -- f (g x) --> (f . g) x
- Hard $
- rr (\f g x -> f `a` (g `a` x))
- (\f g x -> (f `c` g) `a` x),
- -- (>>=) --> flip (=<<)
- Hard $
- rr bindE
- (flipE `a` extE),
- -- (.) id --> id
- rr (compE `a` idE)
- idE,
- -- (++) [x] --> (:) x
- rr (\x -> appendE `a` (consE `a` x `a` nilE))
- (\x -> consE `a` x),
- -- (=<<) return --> id
- rr (extE `a` returnE)
- idE,
- -- (=<<) f (return x) -> f x
- rr (\f x -> extE `a` f `a` (returnE `a` x))
- (\f x -> f `a` x),
- -- (=<<) ((=<<) f . g) --> (=<<) f . (=<<) g
- rr (\f g -> extE `a` ((extE `a` f) `c` g))
- (\f g -> (extE `a` f) `c` (extE `a` g)),
- -- flip (f . g) --> flip (.) g . flip f
- Hard $
- rr (\f g -> flipE `a` (f `c` g))
- (\f g -> (flipE `a` compE `a` g) `c` (flipE `a` f)),
- -- flip (.) f . flip id --> flip f
- rr (\f -> (flipE `a` compE `a` f) `c` (flipE `a` idE))
- (\f -> flipE `a` f),
- -- flip (.) f . flip flip --> flip (flip . f)
- rr (\f -> (flipE `a` compE `a` f) `c` (flipE `a` flipE))
- (\f -> flipE `a` (flipE `c` f)),
- -- flip (flip (flip . f) g) --> flip (flip . flip f) g
- rr1 (\f g -> flipE `a` (flipE `a` (flipE `c` f) `a` g))
- (\f g -> flipE `a` (flipE `c` flipE `a` f) `a` g),
-
- -- flip (.) id --> id
- rr (flipE `a` compE `a` idE)
- idE,
- -- (.) . flip id --> flip flip
- rr (compE `c` (flipE `a` idE))
- (flipE `a` flipE),
- -- s const x y --> y
- rr (\x y -> sE `a` constE `a` x `a` y)
- (\_ y -> y),
- -- s (const . f) g --> f
- rr1 (\f g -> sE `a` (constE `c` f) `a` g)
- (\f _ -> f),
- -- s (const f) --> (.) f
- rr (\f -> sE `a` (constE `a` f))
- (\f -> compE `a` f),
- -- s (f . fst) snd --> uncurry f
- rr (\f -> sE `a` (f `c` fstE) `a` sndE)
- (\f -> uncurryE `a` f),
- -- fst (join (,) x) --> x
- rr (\x -> fstE `a` (joinE `a` commaE `a` x))
- (\x -> x),
- -- snd (join (,) x) --> x
- rr (\x -> sndE `a` (joinE `a` commaE `a` x))
- (\x -> x),
- -- The next two are `simplifies', strictly speaking, but invoked rarely.
- -- uncurry f (x,y) --> f x y
--- rr (\f x y -> uncurryE `a` f `a` (commaE `a` x `a` y))
--- (\f x y -> f `a` x `a` y),
- -- curry (uncurry f) --> f
- rr (\f -> curryE `a` (uncurryE `a` f))
- (\f -> f),
- -- uncurry (curry f) --> f
- rr (\f -> uncurryE `a` (curryE `a` f))
- (\f -> f),
- -- (const id . f) --> const id
- rr (\f -> (constE `a` idE) `c` f)
- (\_ -> constE `a` idE),
- -- const x . f --> const x
- rr (\x f -> constE `a` x `c` f)
- (\x _ -> constE `a` x),
- -- fix f --> f (fix x)
- Hard $
- rr0 (\f -> fixE `a` f)
- (\f -> f `a` (fixE `a` f)),
- -- f (fix f) --> fix x
- Hard $
- rr0 (\f -> f `a` (fixE `a` f))
- (\f -> fixE `a` f),
- -- fix f --> f (f (fix x))
- Hard $
- rr0 (\f -> fixE `a` f)
- (\f -> f `a` (f `a` (fixE `a` f))),
- -- fix (const f) --> f
- rr (\f -> fixE `a` (constE `a` f))
- (\f -> f),
- -- flip const x --> id
- rr (\x -> flipE `a` constE `a` x)
- (\_ -> idE),
- -- const . f --> flip (const f)
- Hard $
- rr (\f -> constE `c` f)
- (\f -> flipE `a` (constE `a` f)),
- -- not (x == y) -> x /= y
- rr2 (\x y -> notE `a` (equalsE `a` x `a` y))
- (\x y -> nequalsE `a` x `a` y),
- -- not (x /= y) -> x == y
- rr2 (\x y -> notE `a` (nequalsE `a` x `a` y))
- (\x y -> equalsE `a` x `a` y),
- If (Or [rr plusE plusE, rr minusE minusE, rr multE multE]) $ down $ Or [
- -- 0 + x --> x
- rr (\x -> plusE `a` zeroE `a` x)
- (\x -> x),
- -- 0 * x --> 0
- rr (\x -> multE `a` zeroE `a` x)
- (\_ -> zeroE),
- -- 1 * x --> x
- rr (\x -> multE `a` oneE `a` x)
- (\x -> x),
- -- x - x --> 0
- rr (\x -> minusE `a` x `a` x)
- (\_ -> zeroE),
- -- x - y + y --> x
- rr (\y x -> plusE `a` (minusE `a` x `a` y) `a` y)
- (\_ x -> x),
- -- x + y - y --> x
- rr (\y x -> minusE `a` (plusE `a` x `a` y) `a` y)
- (\_ x -> x),
- -- x + (y - z) --> x + y - z
- rr (\x y z -> plusE `a` x `a` (minusE `a` y `a` z))
- (\x y z -> minusE `a` (plusE `a` x `a` y) `a` z),
- -- x - (y + z) --> x - y - z
- rr (\x y z -> minusE `a` x `a` (plusE `a` y `a` z))
- (\x y z -> minusE `a` (minusE `a` x `a` y) `a` z),
- -- x - (y - z) --> x + y - z
- rr (\x y z -> minusE `a` x `a` (minusE `a` y `a` z))
- (\x y z -> minusE `a` (plusE `a` x `a` y) `a` z)
- ],
-
- Hard onceRewrites,
- -- join (fmap f x) --> f =<< x
- rr (\f x -> joinE `a` (fmapE `a` f `a` x))
- (\f x -> extE `a` f `a` x),
- -- (=<<) id --> join
- rr (extE `a` idE) joinE,
- -- join --> (=<<) id
- Hard $
- rr joinE (extE `a` idE),
- -- join (return x) --> x
- rr (\x -> joinE `a` (returnE `a` x))
- (\x -> x),
- -- (return . f) =<< m --> fmap f m
- rr (\f m -> extE `a` (returnE `c` f) `a` m)
- (\f m -> fmapIE `a` f `a` m),
- -- (x >>=) . (return .) . f --> flip (fmap . f) x
- rr (\f x -> bindE `a` x `c` (compE `a` returnE) `c` f)
- (\f x -> flipE `a` (fmapIE `c` f) `a` x),
- -- (>>=) (return f) --> flip id f
- rr (\f -> bindE `a` (returnE `a` f))
- (\f -> flipE `a` idE `a` f),
- -- liftM2 f x --> ap (f `fmap` x)
- Hard $
- rr (\f x -> liftM2E `a` f `a` x)
- (\f x -> apE `a` (fmapIE `a` f `a` x)),
- -- liftM2 f (return x) --> fmap (f x)
- rr (\f x -> liftM2E `a` f `a` (returnE `a` x))
- (\f x -> fmapIE `a` (f `a` x)),
- -- f `fmap` return x --> return (f x)
- rr (\f x -> fmapE `a` f `a` (returnE `a` x))
- (\f x -> returnE `a` (f `a` x)),
- -- (=<<) . flip (fmap . f) --> flip liftM2 f
- Hard $
- rr (\f -> extE `c` flipE `a` (fmapE `c` f))
- (\f -> flipE `a` liftM2E `a` f),
-
- -- (.) -> fmap
- Hard $
- rr compE fmapE,
-
- -- map f (zip xs ys) --> zipWith (curry f) xs ys
- Hard $
- rr (\f xs ys -> mapE `a` f `a` (zipE `a` xs `a` ys))
- (\f xs ys -> zipWithE `a` (curryE `a` f) `a` xs `a` ys),
- -- zipWith (,) --> zip (,)
- rr (zipWithE `a` commaE) zipE,
-
- -- all f --> and . map f
- Hard $
- rr (\f -> allE `a` f)
- (\f -> andE `c` mapE `a` f),
- -- and . map f --> all f
- rr (\f -> andE `c` mapE `a` f)
- (\f -> allE `a` f),
- -- any f --> or . map f
- Hard $
- rr (\f -> anyE `a` f)
- (\f -> orE `c` mapE `a` f),
- -- or . map f --> any f
- rr (\f -> orE `c` mapE `a` f)
- (\f -> anyE `a` f),
-
- -- return f `ap` x --> fmap f x
- rr (\f x -> apE `a` (returnE `a` f) `a` x)
- (\f x -> fmapIE `a` f `a` x),
- -- ap (f `fmap` x) --> liftM2 f x
- rr (\f x -> apE `a` (fmapIE `a` f `a` x))
- (\f x -> liftM2E `a` f `a` x),
- -- f `ap` x --> (`fmap` x) =<< f
- Hard $
- rr (\f x -> apE `a` f `a` x)
- (\f x -> extE `a` (flipE `a` fmapIE `a` x) `a` f),
- -- (`fmap` x) =<< f --> f `ap` x
- rr (\f x -> extE `a` (flipE `a` fmapIE `a` x) `a` f)
- (\f x -> apE `a` f `a` x),
- -- (x >>=) . flip (fmap . f) -> liftM2 f x
- rr (\f x -> bindE `a` x `c` flipE `a` (fmapE `c` f))
- (\f x -> liftM2E `a` f `a` x),
-
- -- (f =<< m) x --> f (m x) x
- rr0 (\f m x -> extE `a` f `a` m `a` x)
- (\f m x -> f `a` (m `a` x) `a` x),
- -- (fmap f g x) --> f (g x)
- rr0 (\f g x -> fmapE `a` f `a` g `a` x)
- (\f g x -> f `a` (g `a` x)),
- -- return x y --> y
- rr (\y x -> returnE `a` x `a` y)
- (\y _ -> y),
- -- liftM2 f g h x --> g x `h` h x
- rr0 (\f g h x -> liftM2E `a` f `a` g `a` h `a` x)
- (\f g h x -> f `a` (g `a` x) `a` (h `a` x)),
- -- ap f id --> join f
- rr (\f -> apE `a` f `a` idE)
- (\f -> joinE `a` f),
-
- -- (=<<) const q --> flip (>>) q
- Hard $ -- ??
- rr (\q p -> extE `a` (constE `a` q) `a` p)
- (\q p -> seqME `a` p `a` q),
- -- p >> q --> const q =<< p
- Hard $
- rr (\p q -> seqME `a` p `a` q)
- (\p q -> extE `a` (constE `a` q) `a` p),
-
- -- experimental support for Control.Arrow stuff
- -- (costs quite a bit of performace)
- -- uncurry ((. g) . (,) . f) --> f *** g
- rr (\f g -> uncurryE `a` ((flipE `a` compE `a` g) `c` commaE `c` f))
- (\f g -> crossE `a` f `a` g),
- -- uncurry ((,) . f) --> first f
- rr (\f -> uncurryE `a` (commaE `c` f))
- (\f -> firstE `a` f),
- -- uncurry ((. g) . (,)) --> second g
- rr (\g -> uncurryE `a` ((flipE `a` compE `a` g) `c` commaE))
- (\g -> secondE `a` g),
- -- I think we need all three of them:
- -- uncurry (const f) --> f . snd
- rr (\f -> uncurryE `a` (constE `a` f))
- (\f -> f `c` sndE),
- -- uncurry const --> fst
- rr (uncurryE `a` constE)
- (fstE),
- -- uncurry (const . f) --> f . fst
- rr (\f -> uncurryE `a` (constE `c` f))
- (\f -> f `c` fstE),
-
- -- TODO is this the right place?
- -- [x] --> return x
- Hard $
- rr (\x -> consE `a` x `a` nilE)
- (\x -> returnE `a` x),
- -- list destructors
- Hard $
- If (Or [rr consE consE, rr nilE nilE]) $ Or [
- down $ Or [
- -- length [] --> 0
- rr (lengthE `a` nilE)
- zeroE,
- -- length (x:xs) --> 1 + length xs
- rr (\x xs -> lengthE `a` (consE `a` x `a` xs))
- (\_ xs -> plusE `a` oneE `a` (lengthE `a` xs))
- ],
- -- map/fmap elimination
- down $ Or [
- -- map f (x:xs) --> f x: map f xs
- rr (\f x xs -> mapE `a` f `a` (consE `a` x `a` xs))
- (\f x xs -> consE `a` (f `a` x) `a` (mapE `a` f `a` xs)),
- -- fmap f (x:xs) --> f x: Fmap f xs
- rr (\f x xs -> fmapE `a` f `a` (consE `a` x `a` xs))
- (\f x xs -> consE `a` (f `a` x) `a` (fmapE `a` f `a` xs)),
- -- map f [] --> []
- rr (\f -> mapE `a` f `a` nilE)
- (\_ -> nilE),
- -- fmap f [] --> []
- rr (\f -> fmapE `a` f `a` nilE)
- (\_ -> nilE)
- ],
- -- foldr elimination
- down $ Or [
- -- foldr f z (x:xs) --> f x (foldr f z xs)
- rr (\f x xs z -> (foldrE `a` f `a` z) `a` (consE `a` x `a` xs))
- (\f x xs z -> (f `a` x) `a` (foldrE `a` f `a` z `a` xs)),
- -- foldr f z [] --> z
- rr (\f z -> foldrE `a` f `a` z `a` nilE)
- (\_ z -> z)
- ],
- -- foldl elimination
- down $ Opt (CRR $ assocL ["."]) `Then` Or [
- -- sum xs --> foldl (+) 0 xs
- rr (\xs -> sumE `a` xs)
- (\xs -> foldlE `a` plusE `a` zeroE `a` xs),
- -- product xs --> foldl (*) 1 xs
- rr (\xs -> productE `a` xs)
- (\xs -> foldlE `a` multE `a` oneE `a` xs),
- -- foldl1 f (x:xs) --> foldl f x xs
- rr (\f x xs -> foldl1E `a` f `a` (consE `a` x `a` xs))
- (\f x xs -> foldlE `a` f `a` x `a` xs),
- -- foldl f z (x:xs) --> foldl f (f z x) xs
- rr (\f z x xs -> (foldlE `a` f `a` z) `a` (consE `a` x `a` xs))
- (\f z x xs -> foldlE `a` f `a` (f `a` z `a` x) `a` xs),
- -- foldl f z [] --> z
- rr (\f z -> foldlE `a` f `a` z `a` nilE)
- (\_ z -> z),
- -- special rule:
- -- foldl f z [x] --> f z x
- rr (\f z x -> foldlE `a` f `a` z `a` (returnE `a` x))
- (\f z x -> f `a` z `a` x),
- rr (\f z x -> foldlE `a` f `a` z `a` (consE `a` x `a` nilE))
- (\f z x -> f `a` z `a` x)
- ] `OrElse` (
- -- (:) x --> (++) [x]
- Opt (rr0 (\x -> consE `a` x)
- (\x -> appendE `a` (consE `a` x `a` nilE))) `Then`
- -- More special rule: (:) x . (++) ys --> (++) (x:ys)
- up (rr0 (\x ys -> (consE `a` x) `c` (appendE `a` ys))
- (\x ys -> appendE `a` (consE `a` x `a` ys)))
- )
- ],
-
- -- Complicated Transformations
- CRR (collapseLists),
- up $ Or [CRR (evalUnary unaryBuiltins), CRR (evalBinary binaryBuiltins)],
- up $ CRR (assoc assocOps),
- up $ CRR (assocL assocOps),
- up $ CRR (assocR assocOps),
- Up (CRR (commutative commutativeOps)) $ down $ Or [CRR $ assocL assocLOps,
- CRR $ assocR assocROps],
-
- Hard $ simplifies
- ] `Then` Opt (up simplifies)
-assocLOps, assocROps, assocOps :: [String]
-assocLOps = ["+", "*", "&&", "||", "max", "min"]
-assocROps = [".", "++"]
-assocOps = assocLOps ++ assocROps
-
-commutativeOps :: [String]
-commutativeOps = ["*", "+", "==", "/=", "max", "min"]
-
-unaryBuiltins :: [(String,Unary)]
-unaryBuiltins = [
- ("not", UA (not :: Bool -> Bool)),
- ("negate", UA (negate :: Integer -> Integer)),
- ("signum", UA (signum :: Integer -> Integer)),
- ("abs", UA (abs :: Integer -> Integer))
- ]
-
-binaryBuiltins :: [(String,Binary)]
-binaryBuiltins = [
- ("+", BA ((+) :: Integer -> Integer -> Integer)),
- ("-", BA ((-) :: Integer -> Integer -> Integer)),
- ("*", BA ((*) :: Integer -> Integer -> Integer)),
- ("^", BA ((^) :: Integer -> Integer -> Integer)),
- ("<", BA ((<) :: Integer -> Integer -> Bool)),
- (">", BA ((>) :: Integer -> Integer -> Bool)),
- ("==", BA ((==) :: Integer -> Integer -> Bool)),
- ("/=", BA ((/=) :: Integer -> Integer -> Bool)),
- ("<=", BA ((<=) :: Integer -> Integer -> Bool)),
- (">=", BA ((>=) :: Integer -> Integer -> Bool)),
- ("div", BA (div :: Integer -> Integer -> Integer)),
- ("mod", BA (mod :: Integer -> Integer -> Integer)),
- ("max", BA (max :: Integer -> Integer -> Integer)),
- ("min", BA (min :: Integer -> Integer -> Integer)),
- ("&&", BA ((&&) :: Bool -> Bool -> Bool)),
- ("||", BA ((||) :: Bool -> Bool -> Bool))
- ]
-
diff --git a/library/Plugin/Pl/Transform.hs b/library/Plugin/Pl/Transform.hs
deleted file mode 100644
--- a/library/Plugin/Pl/Transform.hs
+++ /dev/null
@@ -1,119 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-module Plugin.Pl.Transform (
- transform,
- ) where
-
-import Plugin.Pl.Common
-import Plugin.Pl.PrettyPrinter ()
-
-import qualified Data.Map as M
-
-import Data.Graph (stronglyConnComp, flattenSCC, flattenSCCs)
-import Control.Monad.Trans.State
-
-{-
-nub :: Ord a => [a] -> [a]
-nub = nub' S.empty where
- nub' _ [] = []
- nub' set (x:xs)
- | x `S.member` set = nub' set xs
- | otherwise = x: nub' (x `S.insert` set) xs
--}
-
-occursP :: String -> Pattern -> Bool
-occursP v (PVar v') = v == v'
-occursP v (PTuple p1 p2) = v `occursP` p1 || v `occursP` p2
-occursP v (PCons p1 p2) = v `occursP` p1 || v `occursP` p2
-
-freeIn :: String -> Expr -> Int
-freeIn v (Var _ v') = fromEnum $ v == v'
-freeIn v (Lambda pat e) = if v `occursP` pat then 0 else freeIn v e
-freeIn v (App e1 e2) = freeIn v e1 + freeIn v e2
-freeIn v (Let ds e') = if v `elem` map declName ds then 0
- else freeIn v e' + sum [freeIn v e | Define _ e <- ds]
-
-isFreeIn :: String -> Expr -> Bool
-isFreeIn v e = freeIn v e > 0
-
-tuple :: [Expr] -> Expr
-tuple es = foldr1 (\x y -> Var Inf "," `App` x `App` y) es
-
-tupleP :: [String] -> Pattern
-tupleP vs = foldr1 PTuple $ PVar `map` vs
-
-dependsOn :: [Decl] -> Decl -> [Decl]
-dependsOn ds d = [d' | d' <- ds, declName d' `isFreeIn` declExpr d]
-
-unLet :: Expr -> Expr
-unLet (App e1 e2) = App (unLet e1) (unLet e2)
-unLet (Let [] e) = unLet e
-unLet (Let ds e) = unLet $
- (Lambda (tupleP $ declName `map` dsYes) (Let dsNo e)) `App`
- (fix' `App` (Lambda (tupleP $ declName `map` dsYes)
- (tuple $ declExpr `map` dsYes)))
- where
- comps = stronglyConnComp [(d',d',dependsOn ds d') | d' <- ds]
- dsYes = flattenSCC $ head comps
- dsNo = flattenSCCs $ tail comps
-
-unLet (Lambda v e) = Lambda v (unLet e)
-unLet (Var f x) = Var f x
-
-type Env = M.Map String String
-
--- It's a pity we still need that for the pointless transformation.
--- Otherwise a newly created id/const/... could be bound by a lambda
--- e.g. transform' (\id x -> x) ==> transform' (\id -> id) ==> id
-alphaRename :: Expr -> Expr
-alphaRename e = alpha e `evalState` M.empty where
- alpha :: Expr -> State Env Expr
- alpha (Var f v) = do fm <- get; return $ Var f $ maybe v id (M.lookup v fm)
- alpha (App e1 e2) = liftM2 App (alpha e1) (alpha e2)
- alpha (Let _ _) = assert False bt
- alpha (Lambda v e') = inEnv $ liftM2 Lambda (alphaPat v) (alpha e')
-
- -- act like a reader monad
- inEnv :: State s a -> State s a
- inEnv f = gets $ evalState f
-
- alphaPat (PVar v) = do
- fm <- get
- let v' = "$" ++ show (M.size fm)
- put $ M.insert v v' fm
- return $ PVar v'
- alphaPat (PTuple p1 p2) = liftM2 PTuple (alphaPat p1) (alphaPat p2)
- alphaPat (PCons p1 p2) = liftM2 PCons (alphaPat p1) (alphaPat p2)
-
-
-transform :: Expr -> Expr
-transform = transform' . alphaRename . unLet
-
-transform' :: Expr -> Expr
-transform' (Let {}) = assert False bt
-transform' (Var f v) = Var f v
-transform' (App e1 e2) = App (transform' e1) (transform' e2)
-transform' (Lambda (PTuple p1 p2) e)
- = transform' $ Lambda (PVar "z") $
- (Lambda p1 $ Lambda p2 $ e) `App` f `App` s where
- f = Var Pref "fst" `App` Var Pref "z"
- s = Var Pref "snd" `App` Var Pref "z"
-transform' (Lambda (PCons p1 p2) e)
- = transform' $ Lambda (PVar "z") $
- (Lambda p1 $ Lambda p2 $ e) `App` f `App` s where
- f = Var Pref "head" `App` Var Pref "z"
- s = Var Pref "tail" `App` Var Pref "z"
-transform' (Lambda (PVar v) e) = transform' $ getRidOfV e where
- getRidOfV (Var f v') | v == v' = id'
- | otherwise = const' `App` Var f v'
- getRidOfV l@(Lambda pat _) = assert (not $ v `occursP` pat) $
- getRidOfV $ transform' l
- getRidOfV (Let {}) = assert False bt
- getRidOfV e'@(App e1 e2)
- | fr1 && fr2 = scomb `App` getRidOfV e1 `App` getRidOfV e2
- | fr1 = flip' `App` getRidOfV e1 `App` e2
- | Var _ v' <- e2, v' == v = e1
- | fr2 = comp `App` e1 `App` getRidOfV e2
- | True = const' `App` e'
- where
- fr1 = v `isFreeIn` e1
- fr2 = v `isFreeIn` e2
diff --git a/library/Pointfree.hs b/library/Pointfree.hs
deleted file mode 100644
--- a/library/Pointfree.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-module Pointfree where
-
-import Plugin.Pl.Common (mapTopLevel, mapTopLevel')
-import Plugin.Pl.Optimize (optimize)
-import Plugin.Pl.Parser (parsePF)
-import Plugin.Pl.PrettyPrinter (prettyTopLevel)
-import Plugin.Pl.Transform (transform)
-
-import Data.Maybe (listToMaybe)
-
-{- |
- >>> pointfree "I'm not a valid Haskell expression!"
- []
- >>> pointfree "sum xs = foldr (+) 0 xs"
- ["sum = id (fix (const (foldr (+) 0)))","sum = fix (const (foldr (+) 0))","sum = foldr (+) 0"]
--}
-pointfree :: String -> [String]
-pointfree
- = either
- (const [])
- (map prettyTopLevel . mapTopLevel' optimize . mapTopLevel transform)
- . parsePF
-
-{- |
- >>> pointfree' "I'm not a valid Haskell expression!"
- Nothing
- >>> pointfree' "sum xs = foldr (+) 0 xs"
- Just "sum = foldr (+) 0"
--}
-pointfree' :: String -> Maybe String
-pointfree' = listToMaybe . reverse . pointfree