Skip to content

Commit

Permalink
Wip
Browse files Browse the repository at this point in the history
  • Loading branch information
Shayne Fletcher committed Aug 18, 2019
1 parent 77061dd commit 780dd95
Show file tree
Hide file tree
Showing 5 changed files with 241 additions and 5 deletions.
1 change: 1 addition & 0 deletions .gitignore
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
*~
*_flymake*
TAGS
/dist/
Expand Down
1 change: 1 addition & 0 deletions hlint.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -92,6 +92,7 @@ library
Config.Type
Config.Yaml
GHC.Util
GHC.FreeVars
HSE.All
HSE.Match
HSE.Reduce
Expand Down
100 changes: 100 additions & 0 deletions src/GHC/FreeVars.hs
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,100 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PackageImports #-}

module GHC.FreeVars
(
) where

import "ghc-lib-parser" RdrName
import "ghc-lib-parser" OccName
import "ghc-lib-parser" Name
import "ghc-lib-parser" HsSyn
import "ghc-lib-parser" HsPat
import "ghc-lib-parser" HsExtension
import "ghc-lib-parser" SrcLoc

import Control.Monad
import Data.Data
import Data.Generics.Uniplate.Operations
import Data.Generics.Uniplate.Data
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Set (Set)
import qualified Data.Set as Set

( ^+ ) :: Set OccName -> Set OccName -> Set OccName
( ^+ ) = Set.union
( ^- ) :: Set OccName -> Set OccName -> Set OccName
( ^- ) = Set.difference

data Vars' = Vars' {bound' :: Set OccName, free' :: Set OccName}

instance Semigroup Vars' where
Vars' x1 x2 <> Vars' y1 y2 = Vars' (x1 ^+ y1) (x2 ^+ y2)

instance Monoid Vars' where
mempty = Vars' Set.empty Set.empty
#if !(MIN_VERSION_base(4,11,0))
mappend = (<>)
#endif
mconcat fvs = Vars' (Set.unions $ map bound' fvs) (Set.unions $ map free' fvs)

class AllVars' a where
-- | Return the variables, erring on the side of more free
-- variables.
allVars' :: a -> Vars'

class FreeVars' a where
-- | Return the variables, erring on the side of more free
-- variables.
freeVars' :: a -> Set OccName

freeVars_ :: (FreeVars' a) => a -> Vars'
freeVars_ = Vars' Set.empty . freeVars'

-- `inFree' a b` is the set of free variables in 'a' together with the
-- free variables in 'b' not bound in 'a'.
inFree' :: (AllVars' a, FreeVars' b) => a -> b -> Set OccName
inFree' a b = free' aa ^+ (freeVars' b ^- bound' aa)
where aa = allVars' a

-- `inVars' a b` is a value of `Vars_'` with bound variables the union
-- of the bound variables of 'a' and 'b' and free variables the union
-- of the free variables of 'a' and the free variables of 'b' not
-- bound by 'a'.
inVars' :: (AllVars' a, AllVars' b) => a -> b -> Vars'
inVars' a b =
Vars' (bound' aa ^+ bound' bb) (free' aa ^+ (free' bb ^- bound' aa))
where aa = allVars' a
bb = allVars' b

unqualNames' :: Located RdrName -> [OccName]
unqualNames' (L _ (Unqual x)) = [x]
unqualNames' (L _ (Exact x)) = [nameOccName x]
unqualNames' _ = []

instance FreeVars' (Set OccName) where
freeVars' = id

instance AllVars' Vars' where
allVars' = id

instance FreeVars' (LHsExpr GhcPs) where -- never has any bound variables
freeVars' (L _ (HsVar _ x)) = Set.fromList $ unqualNames' x
freeVars' (L _ (RecordCon _ _ (HsRecFields flds _))) = Set.unions $ map freeVars' flds
freeVars' (L _ (RecordUpd _ e flds)) = Set.unions $ freeVars' e : map freeVars' flds
-- More to do.
freeVars' x = freeVars' $ children x

instance FreeVars' [LHsExpr GhcPs] where
freeVars' = Set.unions . map freeVars'

instance FreeVars' (LHsRecField GhcPs (LHsExpr GhcPs)) where
freeVars' (L _ (HsRecField _ x _)) = freeVars' x

instance FreeVars' (LHsRecUpdField GhcPs) where
freeVars' (L _ (HsRecField _ x _)) = freeVars' x
79 changes: 74 additions & 5 deletions src/GHC/Util.hs
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,8 @@
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TypeFamilies, NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ViewPatterns, MultiParamTypeClasses , FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-}

module GHC.Util (
Expand All @@ -23,6 +25,10 @@ module GHC.Util (
, SrcSpanD(..)
, isDot, isDol
, pragmas, flags, langExts, mkFlags, mkLangExts
, View'(..)
, Var_'(Var_'), PVar_'(PVar_')
, simplifyExp'
, fromApps', childrenApps', universeApps', apps'
-- Temporary : Export these so GHC doesn't consider them unused and
-- tell weeder to ignore them.
, isAtom, addParen, paren, isApp, isOpApp, isAnyApp, isSection, isDotApp
Expand All @@ -49,6 +55,8 @@ import "ghc-lib-parser" HscTypes
import "ghc-lib-parser" HeaderInfo
import "ghc-lib-parser" ApiAnnotation
import "ghc-lib-parser" Module
import "ghc-lib-parser" Bag
import "ghc-lib-parser" Name

import Control.Applicative
import Data.Maybe
Expand All @@ -58,6 +66,8 @@ import System.FilePath
import Language.Preprocessor.Unlit
import qualified Data.Map.Strict as Map
import Data.Default
import Data.Generics.Uniplate.Operations
import Data.Generics.Uniplate.Data

fakeSettings :: Settings
fakeSettings = Settings
Expand Down Expand Up @@ -297,14 +307,10 @@ modName HsModule {hsmodName=Just (L _ n)} = moduleNameString n
unsafePrettyPrint :: (Outputable.Outputable a) => a -> String
unsafePrettyPrint = Outputable.showSDocUnsafe . Outputable.ppr

-- | Test if two AST elements are equal modulo annotations.
(=~=) :: Eq a => Located a -> Located a -> Bool
a =~= b = unLoc a == unLoc b

-- | Compare two 'Maybe (Located a)' values for equality modulo
-- locations.
eqMaybe:: Eq a => Maybe (Located a) -> Maybe (Located a) -> Bool
eqMaybe (Just x) (Just y) = x =~= y
eqMaybe (Just x) (Just y) = x `eqLocated` y
eqMaybe Nothing Nothing = True
eqMaybe _ _ = False

Expand Down Expand Up @@ -392,3 +398,66 @@ mkFlags loc flags =
mkLangExts :: SrcSpan -> [String] -> Located AnnotationComment
mkLangExts loc exts =
L loc $ AnnBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")

--

class View' a b where
view' :: a -> b

data Var_' = NoVar_' | Var_' String deriving Eq

instance View' (LHsExpr GhcPs) Var_' where
view' (fromParen' -> L _ (HsVar _ (L _ (Unqual x)))) = Var_' $ occNameString x
view' _ = NoVar_'

data PVar_' = NoPVar_' | PVar_' String

instance View' (Pat GhcPs) PVar_' where
view' (fromPParen' -> VarPat _ (L _ x)) = PVar_' $ rdrNameName x
view' _ = NoPVar_'

fromParen' :: LHsExpr GhcPs -> LHsExpr GhcPs
fromParen' (L _ (HsPar _ x)) = fromParen' x
fromParen' x = x

fromPParen' :: Pat GhcPs -> Pat GhcPs
fromPParen' (ParPat _ x) = fromPParen' x
fromPParen' x = x

simplifyExp' :: LHsExpr GhcPs -> LHsExpr GhcPs
-- Appliciation f $ x.
simplifyExp' (L l (OpApp _ x (L _ op) y)) | isDol op = L l (HsApp noext x (noloc (HsPar noext y)))
-- An expression of the form, 'let x = y in z'.
simplifyExp' e@(L _ (HsLet _ (L _ (HsValBinds _ (ValBinds _ binds []))) z)) =
case bagToList binds of
-- Implementing this requires computing 'vars', 'freeVars' and so
-- on. Quite detailed work. Postponing for now to see how far we
-- can get without it.
-- [L _
-- (FunBind {
-- fun_matches =
-- MG {mg_alts =
-- L _ [L _ Match {
-- m_ctxt = FunRhs {mc_fun = x}
-- , m_pats = []
-- , m_grhss = GRHSs {
-- grhssGRHSs = [L _ (GRHS _ [] y)]
-- , grhssLocalBinds=L _ (EmptyLocalBinds _)}}]}})
-- ] -> undefined
_ -> e

simplifyExp' e = e

apps' :: [LHsExpr GhcPs] -> LHsExpr GhcPs
apps' = foldl1' mkApp where mkApp x y = noLoc (HsApp noExt x y)

fromApps' :: LHsExpr GhcPs -> [LHsExpr GhcPs]
fromApps' (L _ (HsApp _ x y)) = fromApps' x ++ [y]
fromApps' x = [x]

childrenApps' :: LHsExpr GhcPs -> [LHsExpr GhcPs]
childrenApps' (L _ (HsApp _ x y)) = childrenApps' x ++ [y]
childrenApps' x = children x

universeApps' :: LHsExpr GhcPs -> [LHsExpr GhcPs]
universeApps' x = x : concatMap universeApps' (childrenApps' x)
65 changes: 65 additions & 0 deletions src/Hint/ListRec.hs
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
{-# LANGUAGE PatternGuards, ViewPatterns #-}
{-# LANGUAGE PackageImports #-}

{-
map f [] = []
Expand Down Expand Up @@ -37,6 +38,16 @@ import Data.Either.Extra
import Control.Monad
import Refact.Types hiding (RType(Match))

import qualified "ghc-lib-parser" SrcLoc as GHC
import "ghc-lib-parser" HsExtension
import "ghc-lib-parser" HsPat
import "ghc-lib-parser" HsTypes
import "ghc-lib-parser" TysWiredIn
import "ghc-lib-parser" FastString
import "ghc-lib-parser" RdrName
import qualified "ghc-lib-parser" HsBinds as GHC
import qualified "ghc-lib-parser" HsExpr as GHC
import GHC.Util

listRecHint :: DeclHint
listRecHint _ _ = concatMap f . universe
Expand All @@ -54,6 +65,7 @@ listRecHint _ _ = concatMap f . universe
recursiveStr :: String
recursiveStr = "_recursive_"
recursive = toNamed recursiveStr
recursiveExpr = noloc $ GHC.HsVar noext (noloc $ mkVarUnqual (fsLit recursiveStr))

-- recursion parameters, nil-case, (x,xs,cons-case)
-- for cons-case delete any recursive calls with xs from them
Expand All @@ -69,6 +81,9 @@ data BList = BNil | BCons String String
data Branch = Branch String [String] Int BList Exp_
deriving Show

data Branch' = Branch' String [String] Int BList (GHC.LHsExpr GhcPs)
-- deriving Show



---------------------------------------------------------------------
Expand Down Expand Up @@ -135,6 +150,12 @@ delCons func pos var (fromApps -> (view -> Var_ x):xs) | func == x = do
return $ apps $ recursive : pre ++ post
delCons _ _ _ x = return x

delCons' :: String -> Int -> String -> GHC.LHsExpr GhcPs -> Maybe (GHC.LHsExpr GhcPs)
delCons' func pos var (fromApps' -> (view' -> Var_' x) : xs) | func == x = do
(pre, (view' -> Var_' v) : post) <- return $ splitAt pos xs
guard $ v == var
return $ apps' $ recursiveExpr : pre ++ post
delCons' _ _ _ x = return x

eliminateArgs :: [String] -> Exp_ -> ([String], Exp_)
eliminateArgs ps cons = (remove ps, transform f cons)
Expand All @@ -146,6 +167,16 @@ eliminateArgs ps cons = (remove ps, transform f cons)
f (fromApps -> x:xs) | x == recursive = apps $ x : remove xs
f x = x

eliminateArgs' :: [String] -> GHC.LHsExpr GhcPs -> ([String], GHC.LHsExpr GhcPs)
eliminateArgs' ps cons = (remove ps, transform f cons)
where
args = [zs | z : zs <- map fromApps' $ universeApps' cons
, W (transformBi (const GHC.noSrcSpan) z) == W recursiveExpr]
elim = [all (\xs -> length xs > i && view' (xs !! i) == Var_' p) args | (i, p) <- zip [0..] ps] ++ repeat False
remove = concat . zipWith (\b x -> [x | not b]) elim

f (fromApps' -> x : xs) | W x == W recursiveExpr = apps' $ x : remove xs
f x = x

---------------------------------------------------------------------
-- FIND A BRANCH
Expand All @@ -156,6 +187,19 @@ findBranch x = do
(a,b,c) <- findPat ps
return $ Branch (fromNamed name) a b c $ simplifyExp bod

findBranch' :: GHC.LMatch GhcPs (GHC.HsExpr GhcPs) -> Maybe Branch'
findBranch' (GHC.L _ x) = do
-- A right hand side of a pattern or function binding that is
-- unguarded and has no local bindings.
GHC.Match { GHC.m_ctxt = GHC.FunRhs {GHC.mc_fun=(GHC.L _ name)}
, GHC.m_pats = ps
, GHC.m_grhss =
GHC.GRHSs {GHC.grhssGRHSs=[GHC.L l (GHC.GRHS _ [] body)]
, GHC.grhssLocalBinds=GHC.L _ (GHC.EmptyLocalBinds _)
}
} <- return x
(a, b, c) <- findPat' ps
return $ Branch' (rdrNameName name) a b c $ simplifyExp' (GHC.L l body)

findPat :: [Pat_] -> Maybe ([String], Int, BList)
findPat ps = do
Expand All @@ -164,9 +208,30 @@ findPat ps = do
let (left,[right]) = partitionEithers ps
return (left, i, right)

-- If all of the patterns in the input list can be interpreted as
-- variables ('x') or list constructions ('x : xs'), then return a
-- triple : the variables, the indices in the input list that
-- correspond to list constructions and lastly the lists. If one or
-- more of the patterns in the input list can't be classified in
-- either of those two ways, return 'Nothing'.
findPat' :: [LPat GhcPs] -> Maybe ([String], Int, BList)
findPat' ps = do
ps <- mapM readPat' ps
[i] <- return $ findIndices isRight ps
let (left, [right]) = partitionEithers ps
return (left, i, right)

readPat :: Pat_ -> Maybe (Either String BList)
readPat (view -> PVar_ x) = Just $ Left x
readPat (PParen _ (PInfixApp _ (view -> PVar_ x) (Special _ Cons{}) (view -> PVar_ xs))) = Just $ Right $ BCons x xs
readPat (PList _ []) = Just $ Right BNil
readPat _ = Nothing

-- Interpret a pattern as a either a variable 'x', a list of form 'x :
-- xs' (or 'Nothing' if neither).
readPat' :: LPat GhcPs -> Maybe (Either String BList)
readPat' (view' -> PVar_' x) = Just $ Left x
readPat' (ParPat _ (ConPatIn (GHC.L _ n) (InfixCon (view' -> PVar_' x) (view' -> PVar_' xs))))
| n == consDataCon_RDR = Just $ Right $ BCons x xs
readPat' (ListPat _ []) = Just $ Right BNil
readPat' _ = Nothing

0 comments on commit 780dd95

Please sign in to comment.