{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
-- Undo pointfree transformations. Plugin code derived from Pl.hs.
module Lambdabot.Plugin.Haskell.Pointful (pointfulPlugin) where

import Lambdabot.Module as Lmb (Module)
import Lambdabot.Plugin
import Lambdabot.Util.Parser (withParsed, prettyPrintInLine)

import Control.Monad.Reader
import Control.Monad.State
import Data.Functor.Identity (Identity)
import Data.Generics
import qualified Data.Set as S
import qualified Data.Map as M
import Data.List
import Data.Maybe
import Language.Haskell.Exts.Simple as Hs

pointfulPlugin :: Lmb.Module ()
pointfulPlugin :: Module ()
pointfulPlugin = Module ()
forall st. Module st
newModule
    { moduleCmds :: ModuleT () LB [Command (ModuleT () LB)]
moduleCmds = [Command (ModuleT () LB)]
-> ModuleT () LB [Command (ModuleT () LB)]
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (String -> Command Identity
command String
"pointful")
            { aliases :: [String]
aliases = [String
"pointy",String
"repoint",String
"unpointless",String
"unpl",String
"unpf"]
            , help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"pointful <expr>. Make code pointier."
            , process :: String -> Cmd (ModuleT () LB) ()
process = (String -> Cmd (ModuleT () LB) ())
-> [String] -> Cmd (ModuleT () LB) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say ([String] -> Cmd (ModuleT () LB) ())
-> (String -> [String]) -> String -> Cmd (ModuleT () LB) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
pointful
            }
        ]
    }

---- Utilities ----

stabilize :: Eq a => (a -> a) -> a -> a
stabilize :: (a -> a) -> a -> a
stabilize a -> a
f a
x = let x' :: a
x' = a -> a
f a
x in if a
x' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x then a
x else (a -> a) -> a -> a
forall a. Eq a => (a -> a) -> a -> a
stabilize a -> a
f a
x'

-- varsBoundHere returns variables bound by top patterns or binders
varsBoundHere :: Data d => d -> S.Set Name
varsBoundHere :: d -> Set Name
varsBoundHere (d -> Maybe Pat
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast -> Just (PVar Name
name)) = Name -> Set Name
forall a. a -> Set a
S.singleton Name
name
varsBoundHere (d -> Maybe Match
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast -> Just (Match Name
name [Pat]
_ Rhs
_ Maybe Binds
_)) = Name -> Set Name
forall a. a -> Set a
S.singleton Name
name
varsBoundHere (d -> Maybe Decl
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast -> Just (PatBind Pat
pat Rhs
_ Maybe Binds
_)) = Pat -> Set Name
forall d. Data d => d -> Set Name
varsBoundHere Pat
pat
varsBoundHere (d -> Maybe Exp
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast -> Just (Exp
_ :: Exp)) = Set Name
forall a. Set a
S.empty
varsBoundHere d
d = [Set Name] -> Set Name
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ((forall d. Data d => d -> Set Name) -> d -> [Set Name]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ forall d. Data d => d -> Set Name
varsBoundHere d
d)

-- note: the tempting idea of using a pattern synonym for the frequent
-- (cast -> Just _) patterns causes compiler crashes with ghc before
-- version 8; cf. https://ghc.haskell.org/trac/ghc/ticket/11336

foldFreeVars :: forall a d. Data d => (Name -> S.Set Name -> a) -> ([a] -> a) -> d -> a
foldFreeVars :: (Name -> Set Name -> a) -> ([a] -> a) -> d -> a
foldFreeVars Name -> Set Name -> a
var [a] -> a
sum d
e = Reader (Set Name) a -> Set Name -> a
forall r a. Reader r a -> r -> a
runReader (d -> Reader (Set Name) a
forall d. Data d => d -> Reader (Set Name) a
go d
e) Set Name
forall a. Set a
S.empty where
    go :: forall d. Data d => d -> Reader (S.Set Name) a
    go :: d -> Reader (Set Name) a
go (d -> Maybe Exp
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast -> Just (Var (UnQual Name
name))) =
        (Set Name -> a) -> Reader (Set Name) a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Name -> Set Name -> a
var Name
name)
    go (d -> Maybe Exp
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast -> Just (Lambda [Pat]
ps Exp
exp)) =
        [Set Name] -> Reader (Set Name) a -> Reader (Set Name) a
forall a b.
Ord a =>
[Set a] -> Reader (Set a) b -> Reader (Set a) b
bind [[Pat] -> Set Name
forall d. Data d => d -> Set Name
varsBoundHere [Pat]
ps] (Reader (Set Name) a -> Reader (Set Name) a)
-> Reader (Set Name) a -> Reader (Set Name) a
forall a b. (a -> b) -> a -> b
$ Exp -> Reader (Set Name) a
forall d. Data d => d -> Reader (Set Name) a
go Exp
exp
    go (d -> Maybe Exp
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast -> Just (Let Binds
bs Exp
exp)) =
        [Set Name] -> Reader (Set Name) a -> Reader (Set Name) a
forall a b.
Ord a =>
[Set a] -> Reader (Set a) b -> Reader (Set a) b
bind [Binds -> Set Name
forall d. Data d => d -> Set Name
varsBoundHere Binds
bs] (Reader (Set Name) a -> Reader (Set Name) a)
-> Reader (Set Name) a -> Reader (Set Name) a
forall a b. (a -> b) -> a -> b
$ [Reader (Set Name) a] -> Reader (Set Name) a
forall (m :: * -> *). Monad m => [m a] -> m a
collect [Binds -> Reader (Set Name) a
forall d. Data d => d -> Reader (Set Name) a
go Binds
bs, Exp -> Reader (Set Name) a
forall d. Data d => d -> Reader (Set Name) a
go Exp
exp]
    go (d -> Maybe Alt
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast -> Just (Alt Pat
pat Rhs
exp Maybe Binds
bs)) =
        [Set Name] -> Reader (Set Name) a -> Reader (Set Name) a
forall a b.
Ord a =>
[Set a] -> Reader (Set a) b -> Reader (Set a) b
bind [Pat -> Set Name
forall d. Data d => d -> Set Name
varsBoundHere Pat
pat, Maybe Binds -> Set Name
forall d. Data d => d -> Set Name
varsBoundHere Maybe Binds
bs] (Reader (Set Name) a -> Reader (Set Name) a)
-> Reader (Set Name) a -> Reader (Set Name) a
forall a b. (a -> b) -> a -> b
$ [Reader (Set Name) a] -> Reader (Set Name) a
forall (m :: * -> *). Monad m => [m a] -> m a
collect [Rhs -> Reader (Set Name) a
forall d. Data d => d -> Reader (Set Name) a
go Rhs
exp, Maybe Binds -> Reader (Set Name) a
forall d. Data d => d -> Reader (Set Name) a
go Maybe Binds
bs]
    go (d -> Maybe Decl
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast -> Just (PatBind Pat
pat Rhs
exp Maybe Binds
bs)) =
        [Set Name] -> Reader (Set Name) a -> Reader (Set Name) a
forall a b.
Ord a =>
[Set a] -> Reader (Set a) b -> Reader (Set a) b
bind [Pat -> Set Name
forall d. Data d => d -> Set Name
varsBoundHere Pat
pat, Maybe Binds -> Set Name
forall d. Data d => d -> Set Name
varsBoundHere Maybe Binds
bs] (Reader (Set Name) a -> Reader (Set Name) a)
-> Reader (Set Name) a -> Reader (Set Name) a
forall a b. (a -> b) -> a -> b
$ [Reader (Set Name) a] -> Reader (Set Name) a
forall (m :: * -> *). Monad m => [m a] -> m a
collect [Rhs -> Reader (Set Name) a
forall d. Data d => d -> Reader (Set Name) a
go Rhs
exp, Maybe Binds -> Reader (Set Name) a
forall d. Data d => d -> Reader (Set Name) a
go Maybe Binds
bs]
    go (d -> Maybe Match
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast -> Just (Match Name
_ [Pat]
ps Rhs
exp Maybe Binds
bs)) =
        [Set Name] -> Reader (Set Name) a -> Reader (Set Name) a
forall a b.
Ord a =>
[Set a] -> Reader (Set a) b -> Reader (Set a) b
bind [[Pat] -> Set Name
forall d. Data d => d -> Set Name
varsBoundHere [Pat]
ps, Maybe Binds -> Set Name
forall d. Data d => d -> Set Name
varsBoundHere Maybe Binds
bs] (Reader (Set Name) a -> Reader (Set Name) a)
-> Reader (Set Name) a -> Reader (Set Name) a
forall a b. (a -> b) -> a -> b
$ [Reader (Set Name) a] -> Reader (Set Name) a
forall (m :: * -> *). Monad m => [m a] -> m a
collect [Rhs -> Reader (Set Name) a
forall d. Data d => d -> Reader (Set Name) a
go Rhs
exp, Maybe Binds -> Reader (Set Name) a
forall d. Data d => d -> Reader (Set Name) a
go Maybe Binds
bs]
    go d
d = [Reader (Set Name) a] -> Reader (Set Name) a
forall (m :: * -> *). Monad m => [m a] -> m a
collect ((forall d. Data d => d -> Reader (Set Name) a)
-> d -> [Reader (Set Name) a]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ forall d. Data d => d -> Reader (Set Name) a
go d
d)

    collect :: forall m. Monad m => [m a] -> m a
    collect :: [m a] -> m a
collect [m a]
ms = [a] -> a
sum ([a] -> a) -> m [a] -> m a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` [m a] -> m [a]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [m a]
ms

    bind :: forall a b. Ord a => [S.Set a] -> Reader (S.Set a) b -> Reader (S.Set a) b
    bind :: [Set a] -> Reader (Set a) b -> Reader (Set a) b
bind [Set a]
ss = (Set a -> Set a) -> Reader (Set a) b -> Reader (Set a) b
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ([Set a] -> Set a
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Set a]
ss Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`S.union`)

-- return free variables
freeVars :: Data d => d -> S.Set Name
freeVars :: d -> Set Name
freeVars = (Name -> Set Name -> Set Name)
-> ([Set Name] -> Set Name) -> d -> Set Name
forall a d.
Data d =>
(Name -> Set Name -> a) -> ([a] -> a) -> d -> a
foldFreeVars (\Name
name Set Name
bv -> Name -> Set Name
forall a. a -> Set a
S.singleton Name
name Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Name
bv) [Set Name] -> Set Name
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions

-- return number of free occurrences of a variable
countOcc :: Data d => Name -> d -> Int
countOcc :: Name -> d -> Int
countOcc Name
name = (Name -> Set Name -> Int) -> ([Int] -> Int) -> d -> Int
forall a d.
Data d =>
(Name -> Set Name -> a) -> ([a] -> a) -> d -> a
foldFreeVars Name -> Set Name -> Int
forall p. Num p => Name -> Set Name -> p
var [Int] -> Int
sum where
    sum :: [Int] -> Int
sum = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
0
    var :: Name -> Set Name -> p
var Name
name' Set Name
bv = if Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
name' Bool -> Bool -> Bool
|| Name
name' Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Name
bv then p
0 else p
1

-- variable capture avoiding substitution
substAvoiding :: Data d => M.Map Name Exp -> S.Set Name -> d -> d
substAvoiding :: Map Name Exp -> Set Name -> d -> d
substAvoiding Map Name Exp
subst Set Name
bv = d -> d
forall d. Data d => d -> d
base (d -> d) -> (Exp -> Exp) -> d -> d
forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`extT` Exp -> Exp
exp (d -> d) -> (Alt -> Alt) -> d -> d
forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`extT` Alt -> Alt
alt (d -> d) -> (Decl -> Decl) -> d -> d
forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`extT` Decl -> Decl
decl (d -> d) -> (Match -> Match) -> d -> d
forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`extT` Match -> Match
match where
    base :: Data d => d -> d
    base :: d -> d
base = (forall d. Data d => d -> d) -> d -> d
forall a. Data a => (forall d. Data d => d -> d) -> a -> a
gmapT (Map Name Exp -> Set Name -> b -> b
forall d. Data d => Map Name Exp -> Set Name -> d -> d
substAvoiding Map Name Exp
subst Set Name
bv)

    exp :: Exp -> Exp
exp e :: Exp
e@(Var (UnQual Name
name)) =
        Exp -> Maybe Exp -> Exp
forall a. a -> Maybe a -> a
fromMaybe Exp
e (Name -> Map Name Exp -> Maybe Exp
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name Map Name Exp
subst)
    exp (Lambda [Pat]
ps Exp
exp) =
        let (Map Name Exp
subst', Set Name
bv', [Pat]
ps') = Map Name Exp
-> Set Name -> [Pat] -> (Map Name Exp, Set Name, [Pat])
forall d.
Data d =>
Map Name Exp -> Set Name -> d -> (Map Name Exp, Set Name, d)
renameBinds Map Name Exp
subst Set Name
bv [Pat]
ps
        in  [Pat] -> Exp -> Exp
Lambda [Pat]
ps' (Map Name Exp -> Set Name -> Exp -> Exp
forall d. Data d => Map Name Exp -> Set Name -> d -> d
substAvoiding Map Name Exp
subst' Set Name
bv' Exp
exp)
    exp (Let Binds
bs Exp
exp) =
        let (Map Name Exp
subst', Set Name
bv', Binds
bs') = Map Name Exp
-> Set Name -> Binds -> (Map Name Exp, Set Name, Binds)
forall d.
Data d =>
Map Name Exp -> Set Name -> d -> (Map Name Exp, Set Name, d)
renameBinds Map Name Exp
subst Set Name
bv Binds
bs
        in  Binds -> Exp -> Exp
Let (Map Name Exp -> Set Name -> Binds -> Binds
forall d. Data d => Map Name Exp -> Set Name -> d -> d
substAvoiding Map Name Exp
subst' Set Name
bv' Binds
bs') (Map Name Exp -> Set Name -> Exp -> Exp
forall d. Data d => Map Name Exp -> Set Name -> d -> d
substAvoiding Map Name Exp
subst' Set Name
bv' Exp
exp)
    exp Exp
d = Exp -> Exp
forall d. Data d => d -> d
base Exp
d

    alt :: Alt -> Alt
alt (Alt Pat
pat Rhs
exp Maybe Binds
bs) =
        let (Map Name Exp
subst1, Set Name
bv1, Pat
pat') = Map Name Exp -> Set Name -> Pat -> (Map Name Exp, Set Name, Pat)
forall d.
Data d =>
Map Name Exp -> Set Name -> d -> (Map Name Exp, Set Name, d)
renameBinds Map Name Exp
subst Set Name
bv Pat
pat
            (Map Name Exp
subst', Set Name
bv', Maybe Binds
bs') = Map Name Exp
-> Set Name -> Maybe Binds -> (Map Name Exp, Set Name, Maybe Binds)
forall d.
Data d =>
Map Name Exp -> Set Name -> d -> (Map Name Exp, Set Name, d)
renameBinds Map Name Exp
subst1 Set Name
bv1 Maybe Binds
bs
        in  Pat -> Rhs -> Maybe Binds -> Alt
Alt Pat
pat' (Map Name Exp -> Set Name -> Rhs -> Rhs
forall d. Data d => Map Name Exp -> Set Name -> d -> d
substAvoiding Map Name Exp
subst' Set Name
bv' Rhs
exp) (Map Name Exp -> Set Name -> Maybe Binds -> Maybe Binds
forall d. Data d => Map Name Exp -> Set Name -> d -> d
substAvoiding Map Name Exp
subst' Set Name
bv' Maybe Binds
bs')

    decl :: Decl -> Decl
decl (PatBind Pat
pat Rhs
exp Maybe Binds
bs) =
        let (Map Name Exp
subst', Set Name
bv', Maybe Binds
bs') = Map Name Exp
-> Set Name -> Maybe Binds -> (Map Name Exp, Set Name, Maybe Binds)
forall d.
Data d =>
Map Name Exp -> Set Name -> d -> (Map Name Exp, Set Name, d)
renameBinds Map Name Exp
subst Set Name
bv Maybe Binds
bs in
        Pat -> Rhs -> Maybe Binds -> Decl
PatBind Pat
pat (Map Name Exp -> Set Name -> Rhs -> Rhs
forall d. Data d => Map Name Exp -> Set Name -> d -> d
substAvoiding Map Name Exp
subst' Set Name
bv' Rhs
exp) (Map Name Exp -> Set Name -> Maybe Binds -> Maybe Binds
forall d. Data d => Map Name Exp -> Set Name -> d -> d
substAvoiding Map Name Exp
subst' Set Name
bv' Maybe Binds
bs')
    decl Decl
d = Decl -> Decl
forall d. Data d => d -> d
base Decl
d

    match :: Match -> Match
match (Match Name
name [Pat]
ps Rhs
exp Maybe Binds
bs) =
        let (Map Name Exp
subst1, Set Name
bv1, [Pat]
ps') = Map Name Exp
-> Set Name -> [Pat] -> (Map Name Exp, Set Name, [Pat])
forall d.
Data d =>
Map Name Exp -> Set Name -> d -> (Map Name Exp, Set Name, d)
renameBinds Map Name Exp
subst Set Name
bv [Pat]
ps
            (Map Name Exp
subst', Set Name
bv', Maybe Binds
bs') = Map Name Exp
-> Set Name -> Maybe Binds -> (Map Name Exp, Set Name, Maybe Binds)
forall d.
Data d =>
Map Name Exp -> Set Name -> d -> (Map Name Exp, Set Name, d)
renameBinds Map Name Exp
subst1 Set Name
bv1 Maybe Binds
bs
        in  Name -> [Pat] -> Rhs -> Maybe Binds -> Match
Match Name
name [Pat]
ps' (Map Name Exp -> Set Name -> Rhs -> Rhs
forall d. Data d => Map Name Exp -> Set Name -> d -> d
substAvoiding Map Name Exp
subst' Set Name
bv' Rhs
exp) (Map Name Exp -> Set Name -> Maybe Binds -> Maybe Binds
forall d. Data d => Map Name Exp -> Set Name -> d -> d
substAvoiding Map Name Exp
subst' Set Name
bv' Maybe Binds
bs')

-- rename local binders (but not the nested expressions)
renameBinds :: Data d => M.Map Name Exp -> S.Set Name -> d -> (M.Map Name Exp, S.Set Name, d)
renameBinds :: Map Name Exp -> Set Name -> d -> (Map Name Exp, Set Name, d)
renameBinds Map Name Exp
subst Set Name
bv d
d = (Map Name Exp
subst', Set Name
bv', d
d') where
    (d
d', (Map Name Exp
subst', Set Name
bv', Map Name Name
_)) = State (Map Name Exp, Set Name, Map Name Name) d
-> (Map Name Exp, Set Name, Map Name Name)
-> (d, (Map Name Exp, Set Name, Map Name Name))
forall s a. State s a -> s -> (a, s)
runState (d -> State (Map Name Exp, Set Name, Map Name Name) d
forall d.
Data d =>
d -> State (Map Name Exp, Set Name, Map Name Name) d
go d
d) (Map Name Exp
subst, Set Name
bv, Map Name Name
forall k a. Map k a
M.empty)

    go, base :: Data d => d -> State (M.Map Name Exp, S.Set Name, M.Map Name Name) d
    go :: d -> State (Map Name Exp, Set Name, Map Name Name) d
go = d -> State (Map Name Exp, Set Name, Map Name Name) d
forall d.
Data d =>
d -> State (Map Name Exp, Set Name, Map Name Name) d
base (d -> State (Map Name Exp, Set Name, Map Name Name) d)
-> (Pat
    -> StateT (Map Name Exp, Set Name, Map Name Name) Identity Pat)
-> d
-> State (Map Name Exp, Set Name, Map Name Name) d
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` Pat -> StateT (Map Name Exp, Set Name, Map Name Name) Identity Pat
pat (d -> State (Map Name Exp, Set Name, Map Name Name) d)
-> (Match
    -> StateT (Map Name Exp, Set Name, Map Name Name) Identity Match)
-> d
-> State (Map Name Exp, Set Name, Map Name Name) d
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` Match
-> StateT (Map Name Exp, Set Name, Map Name Name) Identity Match
match (d -> State (Map Name Exp, Set Name, Map Name Name) d)
-> (Decl
    -> StateT (Map Name Exp, Set Name, Map Name Name) Identity Decl)
-> d
-> State (Map Name Exp, Set Name, Map Name Name) d
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` Decl
-> StateT (Map Name Exp, Set Name, Map Name Name) Identity Decl
decl (d -> State (Map Name Exp, Set Name, Map Name Name) d)
-> (Exp
    -> StateT (Map Name Exp, Set Name, Map Name Name) Identity Exp)
-> d
-> State (Map Name Exp, Set Name, Map Name Name) d
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(a -> m a) -> (b -> m b) -> a -> m a
`extM` Exp -> StateT (Map Name Exp, Set Name, Map Name Name) Identity Exp
forall (m :: * -> *). Monad m => Exp -> m Exp
exp
    base :: d -> State (Map Name Exp, Set Name, Map Name Name) d
base d
d = (forall d.
 Data d =>
 d -> State (Map Name Exp, Set Name, Map Name Name) d)
-> d -> State (Map Name Exp, Set Name, Map Name Name) d
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> a -> m a
gmapM forall d.
Data d =>
d -> State (Map Name Exp, Set Name, Map Name Name) d
go d
d

    pat :: Pat -> StateT (Map Name Exp, Set Name, Map Name Name) Identity Pat
pat (PVar Name
name) = Name -> Pat
PVar (Name -> Pat)
-> StateT (Map Name Exp, Set Name, Map Name Name) Identity Name
-> StateT (Map Name Exp, Set Name, Map Name Name) Identity Pat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name
-> StateT (Map Name Exp, Set Name, Map Name Name) Identity Name
rename Name
name
    pat Pat
d = Pat -> StateT (Map Name Exp, Set Name, Map Name Name) Identity Pat
forall d.
Data d =>
d -> State (Map Name Exp, Set Name, Map Name Name) d
base Pat
d

    match :: Match
-> StateT (Map Name Exp, Set Name, Map Name Name) Identity Match
match (Match Name
name [Pat]
ps Rhs
exp Maybe Binds
bs) = do
        Name
name' <- Name
-> StateT (Map Name Exp, Set Name, Map Name Name) Identity Name
rename Name
name
        Match
-> StateT (Map Name Exp, Set Name, Map Name Name) Identity Match
forall (m :: * -> *) a. Monad m => a -> m a
return (Match
 -> StateT (Map Name Exp, Set Name, Map Name Name) Identity Match)
-> Match
-> StateT (Map Name Exp, Set Name, Map Name Name) Identity Match
forall a b. (a -> b) -> a -> b
$ Name -> [Pat] -> Rhs -> Maybe Binds -> Match
Match Name
name' [Pat]
ps Rhs
exp Maybe Binds
bs

    decl :: Decl
-> StateT (Map Name Exp, Set Name, Map Name Name) Identity Decl
decl (PatBind Pat
pat Rhs
exp Maybe Binds
bs) = do
        Pat
pat' <- Pat -> StateT (Map Name Exp, Set Name, Map Name Name) Identity Pat
forall d.
Data d =>
d -> State (Map Name Exp, Set Name, Map Name Name) d
go Pat
pat
        Decl
-> StateT (Map Name Exp, Set Name, Map Name Name) Identity Decl
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl
 -> StateT (Map Name Exp, Set Name, Map Name Name) Identity Decl)
-> Decl
-> StateT (Map Name Exp, Set Name, Map Name Name) Identity Decl
forall a b. (a -> b) -> a -> b
$ Pat -> Rhs -> Maybe Binds -> Decl
PatBind Pat
pat' Rhs
exp Maybe Binds
bs
    decl Decl
d = Decl
-> StateT (Map Name Exp, Set Name, Map Name Name) Identity Decl
forall d.
Data d =>
d -> State (Map Name Exp, Set Name, Map Name Name) d
base Decl
d

    exp :: Exp -> m Exp
exp (Exp
e :: Exp) = Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
e

    rename :: Name -> State (M.Map Name Exp, S.Set Name, M.Map Name Name) Name
    rename :: Name
-> StateT (Map Name Exp, Set Name, Map Name Name) Identity Name
rename Name
name = do
        (Map Name Exp
subst, Set Name
bv, Map Name Name
ass) <- StateT
  (Map Name Exp, Set Name, Map Name Name)
  Identity
  (Map Name Exp, Set Name, Map Name Name)
forall s (m :: * -> *). MonadState s m => m s
get
        case (Name
name Name -> Map Name Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map Name Name
ass, Name
name Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Name
bv) of
            (Just Name
name', Bool
_) -> do
                 Name
-> StateT (Map Name Exp, Set Name, Map Name Name) Identity Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
name'
            (Maybe Name
_, Bool
False) -> do
                (Map Name Exp, Set Name, Map Name Name)
-> StateT (Map Name Exp, Set Name, Map Name Name) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Name -> Map Name Exp -> Map Name Exp
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Name
name Map Name Exp
subst, Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
S.insert Name
name Set Name
bv, Map Name Name
ass)
                Name
-> StateT (Map Name Exp, Set Name, Map Name Name) Identity Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
name
            (Maybe Name, Bool)
_ -> do
                let name' :: Name
name' = Name -> Set Name -> Name
freshNameAvoiding Name
name Set Name
bv
                (Map Name Exp, Set Name, Map Name Name)
-> StateT (Map Name Exp, Set Name, Map Name Name) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Name -> Exp -> Map Name Exp -> Map Name Exp
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
name (QName -> Exp
Var (Name -> QName
UnQual Name
name')) Map Name Exp
subst,
                     Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
S.insert Name
name' Set Name
bv, Name -> Name -> Map Name Name -> Map Name Name
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
name Name
name' Map Name Name
ass)
                Name
-> StateT (Map Name Exp, Set Name, Map Name Name) Identity Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
name'

-- generate fresh names
freshNameAvoiding :: Name -> S.Set Name -> Name
freshNameAvoiding :: Name -> Set Name -> Name
freshNameAvoiding Name
name Set Name
forbidden  = String -> Name
con (String
pre String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suf) where
    (String -> Name
con, String
nm, String
cs) = case Name
name of
         Ident  String
n -> (String -> Name
Ident,  String
n, String
"0123456789")
         Symbol String
n -> (String -> Name
Symbol, String
n, String
"?#")
    pre :: String
pre = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
cs) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
nm
    sufs :: [String]
sufs = [Int
1..] [Int] -> (Int -> [String]) -> [String]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int -> String -> [String]) -> String -> Int -> [String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> String -> [String]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM String
cs
    suf :: String
suf = [String] -> String
forall a. [a] -> a
head ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\String
suf -> String -> Name
con (String
pre String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suf) Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Name
forbidden) [String]
sufs

---- Optimization (removing explicit lambdas) and restoration of infix ops ----

-- move lambda patterns into LHS
optimizeD :: Decl -> Decl
optimizeD :: Decl -> Decl
optimizeD (PatBind (PVar Name
fname) (UnGuardedRhs (Lambda [Pat]
pats Exp
rhs)) Maybe Binds
Nothing) =
    let (Map Name Exp
subst, Set Name
bv, [Pat]
pats') = Map Name Exp
-> Set Name -> [Pat] -> (Map Name Exp, Set Name, [Pat])
forall d.
Data d =>
Map Name Exp -> Set Name -> d -> (Map Name Exp, Set Name, d)
renameBinds Map Name Exp
forall k a. Map k a
M.empty (Name -> Set Name
forall a. a -> Set a
S.singleton Name
fname) [Pat]
pats
        rhs' :: Exp
rhs' = Map Name Exp -> Set Name -> Exp -> Exp
forall d. Data d => Map Name Exp -> Set Name -> d -> d
substAvoiding Map Name Exp
subst Set Name
bv Exp
rhs
    in  [Match] -> Decl
FunBind [Name -> [Pat] -> Rhs -> Maybe Binds -> Match
Match Name
fname [Pat]
pats' (Exp -> Rhs
UnGuardedRhs Exp
rhs') Maybe Binds
forall a. Maybe a
Nothing]
---- combine function binding and lambda
optimizeD (FunBind [Match Name
fname [Pat]
pats1 (UnGuardedRhs (Lambda [Pat]
pats2 Exp
rhs)) Maybe Binds
Nothing]) =
    let (Map Name Exp
subst, Set Name
bv, [Pat]
pats2') = Map Name Exp
-> Set Name -> [Pat] -> (Map Name Exp, Set Name, [Pat])
forall d.
Data d =>
Map Name Exp -> Set Name -> d -> (Map Name Exp, Set Name, d)
renameBinds Map Name Exp
forall k a. Map k a
M.empty ([Pat] -> Set Name
forall d. Data d => d -> Set Name
varsBoundHere [Pat]
pats1) [Pat]
pats2
        rhs' :: Exp
rhs' = Map Name Exp -> Set Name -> Exp -> Exp
forall d. Data d => Map Name Exp -> Set Name -> d -> d
substAvoiding Map Name Exp
subst Set Name
bv Exp
rhs
    in  [Match] -> Decl
FunBind [Name -> [Pat] -> Rhs -> Maybe Binds -> Match
Match Name
fname ([Pat]
pats1 [Pat] -> [Pat] -> [Pat]
forall a. [a] -> [a] -> [a]
++ [Pat]
pats2') (Exp -> Rhs
UnGuardedRhs Exp
rhs') Maybe Binds
forall a. Maybe a
Nothing]
optimizeD Decl
x = Decl
x

-- remove parens
optimizeRhs :: Rhs -> Rhs
optimizeRhs :: Rhs -> Rhs
optimizeRhs (UnGuardedRhs (Paren Exp
x)) = Exp -> Rhs
UnGuardedRhs Exp
x
optimizeRhs Rhs
x = Rhs
x

optimizeE :: Exp -> Exp
-- apply ((\x z -> ...x...) y) yielding (\z -> ...y...) if there is only one x or y is simple
optimizeE :: Exp -> Exp
optimizeE (App (Lambda (PVar Name
ident : [Pat]
pats) Exp
body) Exp
arg) | Bool
single Bool -> Bool -> Bool
|| Exp -> Bool
simple Exp
arg =
     let (Map Name Exp
subst, Set Name
bv, [Pat]
pats') = Map Name Exp
-> Set Name -> [Pat] -> (Map Name Exp, Set Name, [Pat])
forall d.
Data d =>
Map Name Exp -> Set Name -> d -> (Map Name Exp, Set Name, d)
renameBinds (Name -> Exp -> Map Name Exp
forall k a. k -> a -> Map k a
M.singleton Name
ident Exp
arg) (Exp -> Set Name
forall d. Data d => d -> Set Name
freeVars Exp
arg) [Pat]
pats
     in  Exp -> Exp
Paren ([Pat] -> Exp -> Exp
Lambda [Pat]
pats' (Map Name Exp -> Set Name -> Exp -> Exp
forall d. Data d => Map Name Exp -> Set Name -> d -> d
substAvoiding Map Name Exp
subst Set Name
bv Exp
body))
  where
    single :: Bool
single = Name -> Exp -> Int
forall d. Data d => Name -> d -> Int
countOcc Name
ident Exp
body Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
    simple :: Exp -> Bool
simple Exp
e = case Exp
e of Var QName
_ -> Bool
True; Lit Literal
_ -> Bool
True; Paren Exp
e' -> Exp -> Bool
simple Exp
e'; Exp
_ -> Bool
False
-- apply ((\_ z -> ...) y) yielding (\z -> ...)
optimizeE (App (Lambda (Pat
PWildCard : [Pat]
pats) Exp
body) Exp
_) =
    Exp -> Exp
Paren ([Pat] -> Exp -> Exp
Lambda [Pat]
pats Exp
body)
-- remove 0-arg lambdas resulting from application rules
optimizeE (Lambda [] Exp
b) =
    Exp
b
-- replace (\x -> \y -> z) with (\x y -> z)
optimizeE (Lambda [Pat]
p1 (Lambda [Pat]
p2 Exp
body)) =
    let (Map Name Exp
subst, Set Name
bv, [Pat]
p2') = Map Name Exp
-> Set Name -> [Pat] -> (Map Name Exp, Set Name, [Pat])
forall d.
Data d =>
Map Name Exp -> Set Name -> d -> (Map Name Exp, Set Name, d)
renameBinds Map Name Exp
forall k a. Map k a
M.empty (Exp -> Set Name
forall d. Data d => d -> Set Name
freeVars ([Pat] -> Exp -> Exp
Lambda [Pat]
p2 Exp
body)) [Pat]
p2
        body' :: Exp
body' = Map Name Exp -> Set Name -> Exp -> Exp
forall d. Data d => Map Name Exp -> Set Name -> d -> d
substAvoiding Map Name Exp
subst Set Name
bv Exp
body
    in  [Pat] -> Exp -> Exp
Lambda ([Pat]
p1 [Pat] -> [Pat] -> [Pat]
forall a. [a] -> [a] -> [a]
++ [Pat]
p2') Exp
body'
-- remove double parens
optimizeE (Paren (Paren Exp
x)) =
    Exp -> Exp
Paren Exp
x
-- remove parens around applied lambdas (the pretty printer restores them)
optimizeE (App (Paren (x :: Exp
x@Lambda{})) Exp
y) =
    Exp -> Exp -> Exp
App Exp
x Exp
y
-- remove lambda body parens
optimizeE (Lambda [Pat]
p (Paren Exp
x)) =
    [Pat] -> Exp -> Exp
Lambda [Pat]
p Exp
x
-- remove var, lit parens
optimizeE (Paren x :: Exp
x@(Var QName
_)) =
    Exp
x
optimizeE (Paren x :: Exp
x@(Lit Literal
_)) =
    Exp
x
-- remove infix+lambda parens
optimizeE (InfixApp Exp
a QOp
o (Paren l :: Exp
l@(Lambda [Pat]
_ Exp
_))) =
    Exp -> QOp -> Exp -> Exp
InfixApp Exp
a QOp
o Exp
l
-- remove infix+app aprens
optimizeE (InfixApp (Paren a :: Exp
a@App{}) QOp
o Exp
l) =
    Exp -> QOp -> Exp -> Exp
InfixApp Exp
a QOp
o Exp
l
optimizeE (InfixApp Exp
a QOp
o (Paren l :: Exp
l@App{})) =
    Exp -> QOp -> Exp -> Exp
InfixApp Exp
a QOp
o Exp
l
-- remove left-assoc application parens
optimizeE (App (Paren (App Exp
a Exp
b)) Exp
c) =
    Exp -> Exp -> Exp
App (Exp -> Exp -> Exp
App Exp
a Exp
b) Exp
c
-- restore infix
optimizeE (App (App (Var name' :: QName
name'@(UnQual (Symbol String
_))) Exp
l) Exp
r) =
    (Exp -> QOp -> Exp -> Exp
InfixApp Exp
l (QName -> QOp
QVarOp QName
name') Exp
r)
-- eta reduce
optimizeE (Lambda ps :: [Pat]
ps@(Pat
_:[Pat]
_) (App Exp
e (Var (UnQual Name
v))))
    | Bool
free Bool -> Bool -> Bool
&& [Pat] -> Pat
forall a. [a] -> a
last [Pat]
ps Pat -> Pat -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Pat
PVar Name
v = [Pat] -> Exp -> Exp
Lambda ([Pat] -> [Pat]
forall a. [a] -> [a]
init [Pat]
ps) Exp
e
  where free :: Bool
free = Name -> Exp -> Int
forall d. Data d => Name -> d -> Int
countOcc Name
v Exp
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
-- fail
optimizeE Exp
x = Exp
x

---- Decombinatorization ----

uncomb' :: Exp -> Exp

uncomb' :: Exp -> Exp
uncomb' (Paren (Paren Exp
e)) = Exp -> Exp
Paren Exp
e

-- eliminate sections
uncomb' (RightSection QOp
op' Exp
arg) =
    let a :: Name
a = Name -> Set Name -> Name
freshNameAvoiding (String -> Name
Ident String
"a") (Exp -> Set Name
forall d. Data d => d -> Set Name
freeVars Exp
arg)
    in  (Exp -> Exp
Paren ([Pat] -> Exp -> Exp
Lambda [Name -> Pat
PVar Name
a] (Exp -> QOp -> Exp -> Exp
InfixApp (QName -> Exp
Var (Name -> QName
UnQual Name
a)) QOp
op' Exp
arg)))
uncomb' (LeftSection Exp
arg QOp
op') =
    let a :: Name
a = Name -> Set Name -> Name
freshNameAvoiding (String -> Name
Ident String
"a") (Exp -> Set Name
forall d. Data d => d -> Set Name
freeVars Exp
arg)
    in  (Exp -> Exp
Paren ([Pat] -> Exp -> Exp
Lambda [Name -> Pat
PVar Name
a] (Exp -> QOp -> Exp -> Exp
InfixApp Exp
arg QOp
op' (QName -> Exp
Var (Name -> QName
UnQual Name
a)))))
-- infix to prefix for canonicality
uncomb' (InfixApp Exp
lf (QVarOp QName
name') Exp
rf) =
    (Exp -> Exp
Paren (Exp -> Exp -> Exp
App (Exp -> Exp -> Exp
App (QName -> Exp
Var QName
name') (Exp -> Exp
Paren Exp
lf)) (Exp -> Exp
Paren Exp
rf)))

-- Expand (>>=) when it is obviously the reader monad:

-- rewrite: (>>=) (\x -> e)
-- to:      (\ a b -> a ((\ x -> e) b) b)
uncomb' (App (Var (UnQual (Symbol String
">>="))) (Paren lam :: Exp
lam@Lambda{})) =
   let a :: Name
a = Name -> Set Name -> Name
freshNameAvoiding (String -> Name
Ident String
"a") (Exp -> Set Name
forall d. Data d => d -> Set Name
freeVars Exp
lam)
       b :: Name
b = Name -> Set Name -> Name
freshNameAvoiding (String -> Name
Ident String
"b") (Exp -> Set Name
forall d. Data d => d -> Set Name
freeVars Exp
lam)
   in  (Exp -> Exp
Paren ([Pat] -> Exp -> Exp
Lambda [Name -> Pat
PVar Name
a, Name -> Pat
PVar Name
b]
           (Exp -> Exp -> Exp
App (Exp -> Exp -> Exp
App (QName -> Exp
Var (Name -> QName
UnQual Name
a)) (Exp -> Exp
Paren (Exp -> Exp -> Exp
App Exp
lam (QName -> Exp
Var (Name -> QName
UnQual Name
b))))) (QName -> Exp
Var (Name -> QName
UnQual Name
b)))))
-- rewrite: ((>>=) e1) (\x y -> e2)
-- to:      (\a -> (\x y -> e2) (e1 a) a)
uncomb' (App (App (Var (UnQual (Symbol String
">>="))) Exp
e1) (Paren lam :: Exp
lam@(Lambda (Pat
_:Pat
_:[Pat]
_) Exp
_))) =
    let a :: Name
a = Name -> Set Name -> Name
freshNameAvoiding (String -> Name
Ident String
"a") ([Exp] -> Set Name
forall d. Data d => d -> Set Name
freeVars [Exp
e1,Exp
lam])
    in  (Exp -> Exp
Paren ([Pat] -> Exp -> Exp
Lambda [Name -> Pat
PVar Name
a]
            (Exp -> Exp -> Exp
App (Exp -> Exp -> Exp
App Exp
lam (Exp -> Exp -> Exp
App Exp
e1 (QName -> Exp
Var (Name -> QName
UnQual Name
a)))) (QName -> Exp
Var (Name -> QName
UnQual Name
a)))))

-- fail
uncomb' Exp
expr = Exp
expr

---- Simple combinator definitions ---
combinators :: M.Map Name Exp
combinators :: Map Name Exp
combinators = [(Name, Exp)] -> Map Name Exp
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, Exp)] -> Map Name Exp) -> [(Name, Exp)] -> Map Name Exp
forall a b. (a -> b) -> a -> b
$ (Decl -> (Name, Exp)) -> [Decl] -> [(Name, Exp)]
forall a b. (a -> b) -> [a] -> [b]
map Decl -> (Name, Exp)
declToTuple [Decl]
defs
  where defs :: [Decl]
defs = case String -> ParseResult Module
parseModule String
combinatorModule of
          ParseOk (Hs.Module Maybe ModuleHead
_ [ModulePragma]
_ [ImportDecl]
_ [Decl]
d) -> [Decl]
d
          f :: ParseResult Module
f@(ParseFailed SrcLoc
_ String
_) -> String -> [Decl]
forall a. HasCallStack => String -> a
error (String
"Combinator loading: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseResult Module -> String
forall a. Show a => a -> String
show ParseResult Module
f)
        declToTuple :: Decl -> (Name, Exp)
declToTuple (PatBind (PVar Name
fname) (UnGuardedRhs Exp
body) Maybe Binds
Nothing)
          = (Name
fname, Exp -> Exp
Paren Exp
body)
        declToTuple Decl
_ = String -> (Name, Exp)
forall a. HasCallStack => String -> a
error String
"Pointful Plugin error: can't convert declaration to tuple"

combinatorModule :: String
combinatorModule :: String
combinatorModule = [String] -> String
unlines [
  String
"(.)    = \\f g x -> f (g x)                                          ",
  String
"($)    = \\f x   -> f x                                              ",
  String
"flip   = \\f x y -> f y x                                            ",
  String
"const  = \\x _ -> x                                                  ",
  String
"id     = \\x -> x                                                    ",
  String
"(=<<)  = flip (>>=)                                                  ",
  String
"liftM2 = \\f m1 m2 -> m1 >>= \\x1 -> m2 >>= \\x2 -> return (f x1 x2) ",
  String
"join   = (>>= id)                                                    ",
  String
"ap     = liftM2 id                                                   ",
  String
"(>=>)  = flip (<=<)                                                  ",
  String
"(<=<)  = \\f g x -> f >>= g x                                        ",
  String
"                                                                     ",
  String
"-- ASSUMED reader monad                                              ",
  String
"-- (>>=)  = (\\f k r -> k (f r) r)                                   ",
  String
"-- return = const                                                    ",
  String
""]

---- Top level ----

unfoldCombinators :: (Data a) => a -> a
unfoldCombinators :: a -> a
unfoldCombinators = Map Name Exp -> Set Name -> a -> a
forall d. Data d => Map Name Exp -> Set Name -> d -> d
substAvoiding Map Name Exp
combinators (Map Name Exp -> Set Name
forall d. Data d => d -> Set Name
freeVars Map Name Exp
combinators)

uncombOnce :: (Data a) => a -> a
uncombOnce :: a -> a
uncombOnce a
x = (forall d. Data d => d -> d) -> a -> a
(forall d. Data d => d -> d) -> forall d. Data d => d -> d
everywhere ((Exp -> Exp) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Exp -> Exp
uncomb') a
x
uncomb :: (Eq a, Data a) => a -> a
uncomb :: a -> a
uncomb = (a -> a) -> a -> a
forall a. Eq a => (a -> a) -> a -> a
stabilize a -> a
forall d. Data d => d -> d
uncombOnce

optimizeOnce :: (Data a) => a -> a
optimizeOnce :: a -> a
optimizeOnce a
x = (forall d. Data d => d -> d) -> a -> a
(forall d. Data d => d -> d) -> forall d. Data d => d -> d
everywhere ((Decl -> Decl) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Decl -> Decl
optimizeD (a -> a) -> (Rhs -> Rhs) -> a -> a
forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`extT` Rhs -> Rhs
optimizeRhs (a -> a) -> (Exp -> Exp) -> a -> a
forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`extT` Exp -> Exp
optimizeE) a
x
optimize :: (Eq a, Data a) => a -> a
optimize :: a -> a
optimize = (a -> a) -> a -> a
forall a. Eq a => (a -> a) -> a -> a
stabilize a -> a
forall d. Data d => d -> d
optimizeOnce

pointful :: String -> String
pointful :: String -> String
pointful = (forall a. (Data a, Eq a) => a -> a) -> String -> String
withParsed ((a -> a) -> a -> a
forall a. Eq a => (a -> a) -> a -> a
stabilize (a -> a
forall a. (Eq a, Data a) => a -> a
optimize (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
forall a. (Eq a, Data a) => a -> a
uncomb) (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a) -> a -> a
forall a. Eq a => (a -> a) -> a -> a
stabilize (a -> a
forall d. Data d => d -> d
unfoldCombinators (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
forall a. (Eq a, Data a) => a -> a
uncomb))

-- TODO: merge this into a proper test suite once one exists
-- test s = case parseModule s of
--   f@(ParseFailed _ _) -> fail (show f)
--   ParseOk (Hs.Module _ _ _ _ _ _ defs) ->
--     flip mapM_ defs $ \def -> do
--       putStrLn . prettyPrintInLine  $ def
--       putStrLn . prettyPrintInLine  . uncomb $ def
--       putStrLn . prettyPrintInLine  . optimize . uncomb $ def
--       putStrLn . prettyPrintInLine  . stabilize (optimize . uncomb) $ def
--       putStrLn ""
--
-- 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' .) . (==))) =<<)"
--