haskell-src-exts-util (empty) → 0.1.0
raw patch · 8 files changed
+565/−0 lines, 8 filesdep +basedep +containersdep +data-default
Dependencies added: base, containers, data-default, haskell-src-exts, transformers, uniplate
Files
- LICENSE +29/−0
- README.md +13/−0
- haskell-src-exts-util.cabal +40/−0
- src/Language/Haskell/Exts/Bracket.hs +167/−0
- src/Language/Haskell/Exts/FreeVars.hs +161/−0
- src/Language/Haskell/Exts/Located.hs +93/−0
- src/Language/Haskell/Exts/Util.hs +19/−0
- src/Language/Haskell/Exts/Util/Internal.hs +43/−0
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2017, Pepe Iborra+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++* Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,13 @@+[](https://hackage.haskell.org/package/haskell-src-exts-util)+[](http://stackage.org/nightly/package/haskell-src-exts-util)+[](https://travis-ci.org/pepeiborra/haskell-src-exts-util)+haskell-src-exts-util+=====================+A small suite of helper functions for working with **haskell-src-exts**:+- Free variables+- Bound variables+- Minimal (approximate) rebracketing of AST values such that prettyprint roundtrips.++Acknowledgments+================+This package extracts some the HSE functions in **HLint** and generalizes them. The original code was authored over the years by Neil Mitchell and the rest of HLint contributors.
+ haskell-src-exts-util.cabal view
@@ -0,0 +1,40 @@+-- This file has been generated from package.yaml by hpack version 0.17.1.+--+-- see: https://github.com/sol/hpack++name: haskell-src-exts-util+version: 0.1.0+synopsis: Helper functions for working with haskell-src-exts trees+description: see README.md+category: language+homepage: https://github.com/pepeiborra/haskell-src-exts-util+author: Neil Mitchell, Jose Iborra+maintainer: pepeiborra@gmail.com+copyright: All Rights Reserved+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ README.md++library+ hs-source-dirs:+ src+ build-depends:+ base < 5+ , containers+ , data-default+ , haskell-src-exts+ , transformers+ , uniplate+ exposed-modules:+ Language.Haskell.Exts.Util+ other-modules:+ Language.Haskell.Exts.Bracket+ Language.Haskell.Exts.FreeVars+ Language.Haskell.Exts.Located+ Language.Haskell.Exts.Util.Internal+ Paths_haskell_src_exts_util+ default-language: Haskell2010
+ src/Language/Haskell/Exts/Bracket.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-overlapping-patterns -fno-warn-incomplete-patterns #-}++-- | The contents of this module originate from module+-- [HSE.Bracket](https://github.com/ndmitchell/hlint/blob/master/src/HSE/Bracket.hs)+-- in Neil Mitchell's HLint++module Language.Haskell.Exts.Bracket+ ( Brackets(..)+ , paren+ , transformBracket+ , rebracket1+ , appsBracket+ ) where++import Control.Monad.Trans.State+import Data.Data+import Data.Default+import Data.Generics.Uniplate.Data+import Language.Haskell.Exts.Syntax+import Language.Haskell.Exts.Util.Internal+++class Brackets a where+ remParen :: a -> Maybe a -- remove one paren, or Nothing if there is no paren+ addParen :: a -> a -- write out a paren++ -- | Is this item lexically requiring no bracketing ever+ -- i.e. is totally atomic+ isAtom :: a -> Bool++ -- | Is the child safe free from brackets in the parent position.+ -- Err on the side of caution, True = don't know+ needBracket :: Int -> a -> a -> Bool+++instance (Data l, Default l) => Brackets (Exp l) where+ remParen (Paren _ x) = Just x+ remParen _ = Nothing+ addParen = Paren def++ isAtom x = case x of+ Paren{} -> True+ Tuple{} -> True+ List{} -> True+ LeftSection{} -> True+ RightSection{} -> True+ TupleSection{} -> True+ RecConstr{} -> True+ ListComp{} -> True+ EnumFrom{} -> True+ EnumFromTo{} -> True+ EnumFromThen{} -> True+ EnumFromThenTo{} -> True+ _ -> isLexeme x++ -- note: i is the index in children, not in the AST+ needBracket i parent child+ | isAtom child = False+ | InfixApp{} <- parent, App{} <- child = False+ | isSection parent, App{} <- child = False+ | Let{} <- parent, App{} <- child = False+ | ListComp{} <- parent = False+ | List{} <- parent = False+ | Tuple{} <- parent = False+ | If{} <- parent, isAnyApp child = False+ | App{} <- parent, i == 0, App{} <- child = False+ | ExpTypeSig{} <- parent, i == 0, isApp child = False+ | Paren{} <- parent = False+ | isDotApp parent, isDotApp child, i == 1 = False+ | RecConstr{} <- parent = False+ | RecUpdate{} <- parent, i /= 0 = False+ | Case{} <- parent, i /= 0 || isAnyApp child = False+ | Lambda{} <- parent, i == length (universeBi parent :: [Pat l]) - 1 = False -- watch out for PViewPat+ | Do{} <- parent = False+ | otherwise = True+++instance Default l => Brackets (Type l) where+ remParen (TyParen _ x) = Just x+ remParen _ = Nothing+ addParen = TyParen def++ isAtom x = case x of+ TyParen{} -> True+ TyTuple{} -> True+ TyList{} -> True+ TyVar{} -> True+ TyCon{} -> True+ _ -> False++ needBracket _ parent child+ | isAtom child = False+-- a -> (b -> c) is not a required bracket, but useful for documentation about arity etc.+-- | TyFun{} <- parent, i == 1, TyFun{} <- child = False+ | TyFun{} <- parent, TyApp{} <- child = False+ | TyTuple{} <- parent = False+ | TyList{} <- parent = False+ | TyInfix{} <- parent, TyApp{} <- child = False+ | TyParen{} <- parent = False+ | otherwise = True+++instance Default l => Brackets (Pat l) where+ remParen (PParen _ x) = Just x+ remParen _ = Nothing+ addParen = PParen def++ isAtom x = case x of+ PParen{} -> True+ PTuple{} -> True+ PList{} -> True+ PRec{} -> True+ PVar{} -> True+ PApp _ _ [] -> True+ PWildCard{} -> True+ _ -> False++ needBracket _ parent child+ | isAtom child = False+ | PTuple{} <- parent = False+ | PList{} <- parent = False+ | PInfixApp{} <- parent, PApp{} <- child = False+ | PParen{} <- parent = False+ | otherwise = True+++-- | Add a Paren around something if it is not atomic+paren :: (Data l, Default l) => Exp l -> Exp l+paren x = if isAtom x then x else addParen x+++-- | Descend, and if something changes then add/remove brackets appropriately+descendBracket :: (Data l, Default l) => (Exp l -> (Bool, Exp l)) -> Exp l -> Exp l+descendBracket op x = descendIndex g x+ where+ g i y = if a then f i b else b+ where (a,b) = op y++ f i (Paren _ y) | not $ needBracket i x y = y+ f i y | needBracket i x y = addParen y+ f _ y = y+++transformBracket :: (Data l, Default l) => (Exp l -> Maybe (Exp l)) -> Exp l -> Exp l+transformBracket op = snd . g+ where+ g = f . descendBracket g+ f x = maybe (False,x) ((,) True) (op x)+++-- | Add/remove brackets as suggested needBracket at 1-level of depth+rebracket1 :: (Data l, Default l) => Exp l -> Exp l+rebracket1 = descendBracket (\x -> (True,x))+++-- a list of application, with any necessary brackets+appsBracket :: (Data l, Default l) => [Exp l] -> Exp l+appsBracket = foldl1 (\x -> rebracket1 . App def x)++descendIndex :: Data a => (Int -> a -> a) -> a -> a+descendIndex f x = flip evalState 0 $ flip descendM x $ \y -> do+ i <- get+ modify (+1)+ return $ f i y
+ src/Language/Haskell/Exts/FreeVars.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++-- | The contents of this module originate from module+-- [HSE.FreeVars](https://github.com/ndmitchell/hlint/blob/master/src/HSE/FreeVars.hs)+-- in Neil Mitchell's HLint.+module Language.Haskell.Exts.FreeVars+ ( FreeVars(..)+ , Vars(..)+ , AllVars(..)+ ) where++import Data.Data+import Data.Generics.Uniplate.Data+import Data.Set (Set)+import qualified Data.Set as Set+import Language.Haskell.Exts+import Language.Haskell.Exts.Located+import Prelude++(^+) :: (Data s, Ord s) => Set (Name s) -> Set (Name s) -> Set (Name s)+(^+) = Set.union+(^-) :: (Data s, Ord s) => Set (Name s) -> Set (Name s) -> Set (Name s)+(^-) = Set.difference++data Vars s = Vars {bound :: Set (Name s), free :: Set (Name s)}++instance (Data s, Ord s) => Monoid (Vars s) where+ mempty = Vars Set.empty Set.empty+ mappend (Vars x1 x2) (Vars y1 y2) = Vars (x1 ^+ y1) (x2 ^+ y2)+ mconcat fvs = Vars (Set.unions $ map bound fvs) (Set.unions $ map free fvs)++instance Ord s => Located (Vars s) where+ type LocType (Vars s) = s+ location f (Vars b s)= Vars <$> location f b <*> location f s++class (Located a) => AllVars a where+ -- | Return the variables, erring on the side of more free variables+ allVars :: a -> Vars (LocType a)++class (Located a) => FreeVars a where+ -- | Return the variables, erring on the side of more free variables+ freeVars :: a -> Set (Name (LocType a))++freeVars_ :: FreeVars a => a -> Vars (LocType a)+freeVars_ = Vars Set.empty . freeVars++inFree :: (AllVars a, FreeVars b, Data s, Ord s, s ~ LocType a, s ~ LocType b) => a -> b -> Set (Name s)+inFree a b = free aa ^+ (freeVars b ^- bound aa)+ where aa = allVars a++inVars :: (AllVars a, AllVars b, Data s, Ord s, s ~ LocType a, s ~ LocType b) => a -> b -> Vars s+inVars a b = Vars (bound aa ^+ bound bb) (free aa ^+ (free bb ^- bound aa))+ where aa = allVars a+ bb = allVars b++unqualNames :: QName s -> [Name s]+unqualNames (UnQual _ x) = [x]+unqualNames _ = []++unqualOp :: QOp s -> [Name s]+unqualOp (QVarOp _ x) = unqualNames x+unqualOp (QConOp _ x) = unqualNames x+instance (Data s, Ord s) => FreeVars (Set (Name s)) where+ freeVars = id++instance (Data s, Ord s) => AllVars (Vars s) where+ allVars = id++instance (Data s, Ord s) => FreeVars (Exp s) where -- never has any bound variables+ freeVars (Var _ x) = Set.fromList $ unqualNames x+ freeVars (VarQuote l x) = freeVars $ Var l x+ freeVars (SpliceExp _ (IdSplice l x)) = Set.fromList [Ident l x]+ freeVars (InfixApp _ a op b) = freeVars a ^+ Set.fromList (unqualOp op) ^+ freeVars b+ freeVars (LeftSection _ a op) = freeVars a ^+ Set.fromList (unqualOp op)+ freeVars (RightSection _ op b) = Set.fromList (unqualOp op) ^+ freeVars b+ freeVars (Lambda _ p x) = inFree p x+ freeVars (Let _ bind x) = inFree bind x+ freeVars (Case _ x alts) = freeVars x `mappend` freeVars alts+ freeVars (Do _ xs) = free $ allVars xs+ freeVars (MDo l xs) = freeVars $ Do l xs+ freeVars (ParComp _ x xs) = free xfv ^+ (freeVars x ^- bound xfv)+ where xfv = mconcat $ map allVars xs+ freeVars (ListComp l x xs) = freeVars $ ParComp l x [xs]+ freeVars x = freeVars $ children x++instance (Data s, Ord s) => FreeVars [Exp s] where+ freeVars = Set.unions . map freeVars++instance (Data s, Ord s) => AllVars (Pat s) where+ allVars (PVar _ x) = Vars (Set.singleton x) Set.empty+ allVars (PNPlusK l x _) = allVars (PVar l x)+ allVars (PAsPat l n x) = allVars (PVar l n) `mappend` allVars x+ allVars (PWildCard _) = mempty -- explicitly cannot guess what might be bound here+ allVars (PViewPat _ e p) = freeVars_ e `mappend` allVars p+ allVars x = allVars $ children x++instance (Data s, Ord s) => AllVars [Pat s] where+ allVars = mconcat . map allVars++instance (Data s, Ord s) => FreeVars (Alt s) where+ freeVars (Language.Haskell.Exts.Alt _ pat alt bind) = inFree pat $ inFree bind alt++instance (Data s, Ord s) => FreeVars [Alt s] where+ freeVars = mconcat . map freeVars++instance (Data s, Ord s) => FreeVars (Rhs s) where+ freeVars (UnGuardedRhs _ x) = freeVars x+ freeVars (GuardedRhss _ xs) = mconcat $ map freeVars xs++instance (Data s, Ord s) => FreeVars (GuardedRhs s) where+ freeVars (GuardedRhs _ stmt exp) = inFree stmt exp++instance (Data s, Ord s) => AllVars (QualStmt s) where+ allVars (QualStmt _ x) = allVars x+ allVars x = freeVars_ (childrenBi x :: [Exp s])++instance (Data s, Ord s) => AllVars [QualStmt s] where+ allVars (x:xs) = inVars x xs+ allVars [] = mempty++instance (Data s, Ord s) => AllVars [Stmt s] where+ allVars (x:xs) = inVars x xs+ allVars [] = mempty++instance (Data s, Ord s) => AllVars (Stmt s) where+ allVars (Generator _ pat exp) = allVars pat `mappend` freeVars_ exp+ allVars (Qualifier _ exp) = freeVars_ exp+ allVars (LetStmt _ binds) = allVars binds+ allVars (RecStmt _ stmts) = allVars stmts++instance (Data s, Ord s) => AllVars (Maybe (Binds s)) where+ allVars = maybe mempty allVars++instance (Data s, Ord s) => AllVars (Binds s) where+ allVars (BDecls _ decls) = allVars decls+ allVars (IPBinds _ binds) = freeVars_ binds++instance (Data s, Ord s) => AllVars [Decl s] where+ allVars = mconcat . map allVars++instance (Data s, Ord s) => AllVars (Decl s) where+ allVars (FunBind _ m) = allVars m+ allVars (PatBind _ pat rhs bind) = allVars pat `mappend` freeVars_ (inFree bind rhs)+ allVars _ = mempty++instance (Data s, Ord s) => AllVars [Match s] where+ allVars = mconcat . map allVars++instance (Data s, Ord s) => AllVars (Match s) where+ allVars (Match l name pat rhs binds) = allVars (PVar l name) `mappend` freeVars_ (inFree pat (inFree binds rhs))+ allVars (InfixMatch l p1 name p2 rhs binds) = allVars $ Match l name (p1:p2) rhs binds++instance (Data s, Ord s) => FreeVars [IPBind s] where+ freeVars = mconcat . map freeVars++instance (Data s, Ord s) => FreeVars (IPBind s) where+ freeVars (IPBind _ _ exp) = freeVars exp
+ src/Language/Haskell/Exts/Located.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+module Language.Haskell.Exts.Located+ ( Located(..)+ ) where++import Data.Set (Set)+import qualified Data.Set as Set+import Language.Haskell.Exts++--------------------------------------------------------------------------+-- | Class of types containing source code locations+class Located a where+ type LocType a++ -- | Traversal providing access to the location details+ location :: forall f . Applicative f => (LocType a -> f (LocType a)) -> a -> f a++instance Located (Alt s) where+ type LocType (Alt s) = s+ location = locationForAnnotatedType++instance Located (Binds s) where+ type LocType (Binds s) = s+ location = locationForAnnotatedType++instance Located (Decl s) where+ type LocType (Decl s) = s+ location = locationForAnnotatedType++instance Located (Exp s) where+ type LocType (Exp s) = s+ location = locationForAnnotatedType++instance Located (IPBind s) where+ type LocType (IPBind s) = s+ location = locationForAnnotatedType++instance Located (Pat s) where+ type LocType (Pat s) = s+ location = locationForAnnotatedType++instance Located (Rhs s) where+ type LocType (Rhs s) = s+ location = locationForAnnotatedType++instance Located (GuardedRhs s) where+ type LocType (GuardedRhs s) = s+ location = locationForAnnotatedType++instance Located (Match s) where+ type LocType (Match s) = s+ location = locationForAnnotatedType++instance Located (Name s) where+ type LocType (Name s) = s+ location = locationForAnnotatedType++instance Located (Stmt s) where+ type LocType (Stmt s) = s+ location = locationForAnnotatedType++instance Located (QOp s) where+ type LocType (QOp s) = s+ location = locationForAnnotatedType++instance Located (QualStmt s) where+ type LocType (QualStmt s) = s+ location = locationForAnnotatedType++instance Located a => Located [a] where+ type LocType [a] = LocType a+ location = traverse.location++instance Located a => Located (Maybe a) where+ type LocType (Maybe a) = LocType a+ location = traverse.location++instance (Located a, Ord a) => Located (Set a) where+ type LocType (Set a) = LocType a+ -- | Valid only if it doesn't remove elements from the 'Set'+ location = traverseSet.location+ where+ traverseSet f s = Set.fromList <$> traverse f (Set.toList s)++instance (Located a, Located b, LocType a ~ LocType b) => Located (a,b) where+ type LocType (a,b) = LocType a+ location f (a,b) = (,) <$> location f a <*> location f b++locationForAnnotatedType+ :: (Functor f, Annotated ast)+ => (t -> f t) -> ast t -> f (ast t)+locationForAnnotatedType f x = (\v -> amap (const v) x) <$> f (ann x)
+ src/Language/Haskell/Exts/Util.hs view
@@ -0,0 +1,19 @@+module Language.Haskell.Exts.Util+ ( -- * Types annotated with source code locations+ Located(..)+ -- * Free variables of ASTs+ , FreeVars(..)+ , Vars(..)+ , AllVars(..)+ -- * Rebracketing of ASTs+ , Brackets(..)+ , paren+ , transformBracket+ , rebracket1+ , appsBracket++ ) where++import Language.Haskell.Exts.Bracket+import Language.Haskell.Exts.FreeVars+import Language.Haskell.Exts.Located
+ src/Language/Haskell/Exts/Util/Internal.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++-- | The contents of this module originate from module+-- [HSE.Util](https://github.com/ndmitchell/hlint/blob/master/src/HSE/Util.hs)+-- in Neil Mitchell's HLint.+module Language.Haskell.Exts.Util.Internal where++import Control.Monad+import Data.Data hiding (Fixity)+import Data.Default+import Data.Functor+import Data.Generics.Uniplate.Data+import Data.List+import Data.Maybe+import Language.Haskell.Exts+import Prelude++---------------------------------------------------------------------+-- ACCESSOR/TESTER++-- is* :: Exp l -> Bool+-- is* :: Decl s -> Bool+isApp App{} = True; isApp _ = False+isAnyApp x = isApp x || isInfixApp x+isInfixApp InfixApp{} = True; isInfixApp _ = False++isDot :: QOp s -> Bool+isDot (QVarOp _ (UnQual _ (Symbol _ "."))) = True+isDot _ = False+isSection LeftSection{} = True+isSection RightSection{} = True+isSection _ = False++isDotApp :: Exp s -> Bool+isDotApp (InfixApp _ _ dot _) | isDot dot = True+isDotApp _ = False++isLexeme Var{} = True+isLexeme Con{} = True+isLexeme Lit{} = True+isLexeme _ = False+