v1.0.3

LICENSE

@@ -0,0 +1,20 @@
+Copyright (c) 2005 Thomas J�ger
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject
+to the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY
+KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE
+WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

Main.hs

@@ -0,0 +1,48 @@
+module Main where
+
+import Plugin.Pl.Common
+import Plugin.Pl.Optimize
+import Plugin.Pl.Parser
+import Plugin.Pl.Transform
+
+import Data.List (intersperse)
+import System.Environment (getArgs)
+import System.Console.GetOpt
+
+data Flag = Verbose 
+  deriving Eq
+
+options :: [OptDescr Flag]
+options = [ Option ['v'] ["verbose"] (NoArg Verbose) "verbose results"]
+
+header :: String
+header = "Usage: pointfree [OPTION...] query"
+
+parseArgs :: [String] -> IO ([Flag], [String])
+parseArgs args =
+  case getOpt Permute options args of
+    (flags, nonOptions, []) -> return (flags, nonOptions)
+    (_, _, errs) -> ioError (userError (concat errs ++ usageInfo header options))
+
+main :: IO ()
+main = do
+  args <- getArgs
+  (flags, nonOptions) <- parseArgs args
+  if null nonOptions
+     then putStrLn $ usageInfo header options
+     else let query = concat $ intersperse " " nonOptions
+              verbose = Verbose `elem` flags
+          in pf query verbose
+
+pf :: String -> Bool -> IO ()
+pf input verbose = case parsePF input of
+  Right d ->
+    if verbose
+       then do putStrLn "Transformed to pointfree style:"
+               let d' = mapTopLevel transform d
+               print $ d'
+               putStrLn "Optimized expression:"
+               mapM_ print $ mapTopLevel' optimize d'
+       else print $ last $ mapTopLevel' optimize $ mapTopLevel transform d
+  Left err -> putStrLn err
+

Plugin/Pl/Common.hs

@@ -0,0 +1,149 @@
+{-# OPTIONS -fvia-C #-}
+
+module Plugin.Pl.Common (
+        Fixity(..), Expr(..), Pattern(..), Decl(..), TopLevel(..),
+        bt, sizeExpr, mapTopLevel, mapTopLevel', getExpr,
+        operators, opchars, 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 Text.ParserCombinators.Parsec.Expr (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)
+
+data Pattern
+  = PVar String 
+  | PCons Pattern Pattern
+  | PTuple Pattern Pattern
+  deriving (Eq, Ord)
+
+data Decl = Define { 
+  declName :: String, 
+  declExpr :: Expr
+} deriving (Eq, Ord)
+
+data TopLevel = TLD Bool Decl | TLE Expr deriving (Eq, Ord)
+
+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))
+
+opchars :: [Char]
+opchars = "!@#$%^*./|=-+:?<>&"
+
+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."
+

Plugin/Pl/Optimize.hs

@@ -0,0 +1,105 @@
+{-# OPTIONS -fvia-C -O2 -optc-O3 #-}
+module Plugin.Pl.Optimize (
+    optimize,
+  ) where
+
+import Plugin.Pl.Common
+import Plugin.Pl.Rules
+import Plugin.Pl.PrettyPrinter
+
+import Data.List (nub)
+import Control.Monad.State
+
+cut :: [a] -> [a]
+cut = take 1
+
+toMonadPlus :: MonadPlus m => Maybe a -> m a
+toMonadPlus Nothing = mzero
+toMonadPlus (Just x)= return x
+
+type Size = Double
+-- 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 = fromIntegral (length $ show 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"    = -4
+--                     | str == "s"          = 5
+                     | str == "flip"       = 0.1
+                     | str == ">>="        = 0.05
+                     | str == "$"          = 0.01
+                     | str == "subtract"   = 0.01
+                     | str == "ap"         = 2
+                     | str == "liftM2"     = 1.01
+                     | str == "return"     = -2
+                     | str == "zipWith"    = -4
+                     | str == "const"      = 0 -- -2
+                     | str == "fmap"       = -1
+  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