libhbb 0.3.0.0 → 0.4.0.0
raw patch · 15 files changed
+487/−344 lines, 15 filesdep ~libhbbnew-component:exe:libhbb-cli
Dependency ranges changed: libhbb
Files
- Language/Haskell/HBB/Inline.hs +19/−11
- Language/Haskell/HBB/Internal/GHCHighlevel.hs +54/−27
- Language/Haskell/HBB/Internal/InterfaceTypes.hs +46/−0
- Language/Haskell/HBB/Internal/InternalTTree.hs +28/−57
- Language/Haskell/HBB/Internal/InternalTTreeCreation.hs +102/−37
- Language/Haskell/HBB/Internal/SrcSpan.hs +11/−4
- Language/Haskell/HBB/Locate.hs +7/−4
- Language/Haskell/HBB/OccurrencesOf.hs +28/−18
- Language/Haskell/HBB/SmartInline.hs +14/−7
- Language/Haskell/HBB/TestModes/ApplyTTree.hs +61/−0
- README.md +0/−16
- editor-plugin/vim/hbb.vim +0/−59
- libhbb.cabal +9/−11
- src/HBBSimpleCLI.hs +0/−93
- src/LibHbbCli.hs +108/−0
Language/Haskell/HBB/Inline.hs view
@@ -4,13 +4,15 @@ inline, inlineM, showInlineResult,- InlineOptions(..), BufLoc(..), BufSpan(..),+ NonFirstLinesIndenting(..),+ InlineOptions(..), defaultInlineOptions ) where import Language.Haskell.HBB.Internal.InternalTTreeCreation+import Language.Haskell.HBB.Internal.InterfaceTypes import Language.Haskell.HBB.Internal.InternalTTree import Language.Haskell.HBB.Internal.GHCHighlevel import Language.Haskell.HBB.Internal.TTreeColor@@ -34,17 +36,21 @@ -- used for areas that are identical with the original function or value -- binding (displays) and a bold grey is used for areas that have been added -- and do not occur in the original binding (additions).-data InlineOptions = InlineOptions { showContext :: Bool- , showAnsiColored :: Bool }+data InlineOptions = InlineOptions { showContext :: Bool+ , showAnsiColored :: Bool + , adaptToTargetEnv :: NonFirstLinesIndenting } -- | This value defines the default options for inlining. ----- Most text editors will need these settings. The inlined version of the--- function or value binding is printed without ANSI colors and without context--- but with non-first lines being indented to a level that allows a text editor--- to replace the original name with the return value of mode 'inline'.+-- Most text editors will need these settings (maybe adaptToTargetEnv should be+-- adapted). The inlined version of the function or value binding is printed+-- without ANSI colors and without context but with non-first lines being+-- indented to a level that allows a text editor to replace the original name+-- with the return value of mode 'inline'. defaultInlineOptions :: InlineOptions-defaultInlineOptions = InlineOptions { showContext = False , showAnsiColored = False }+defaultInlineOptions = InlineOptions { showContext = False + , showAnsiColored = False + , adaptToTargetEnv = IgnoreIndOfTargetEnv } -- | This function implements the mode 'inline'. --@@ -55,7 +61,7 @@ -- -- @ -- main :: IO ()--- main = inline [\"-iexample\"] defaultInlineOptions \"example/Example.hs\" 14 13+-- main = inline [\"-iexample\"] defaultInlineOptions \"example/Example.hs\" (BufLoc 14 13) -- @ -- -- It is important to know that the indentation of non-first lines (as of@@ -92,7 +98,7 @@ -- function can be used with a custom GhcMonad instance which allows more -- control about GHCs behaviour. inlineM :: GhcMonad m => InlineOptions -> FilePath -> BufLoc -> Maybe BufLoc -> m (BufSpan,String)-inlineM (InlineOptions { showContext = sc , showAnsiColored = sa })+inlineM (InlineOptions { showContext = sc , showAnsiColored = sa , adaptToTargetEnv = ai }) occFileName startLoc mbEndLoc = do@@ -108,7 +114,9 @@ produceClientTTree sti'@(SearchedTokenInfo { result = (bi,_) }) = let richTTree = runReader (toTTree bi) ProduceLambda inlCol = ((srcLocCol $ realSrcSpanStart $ occSpan sti'))- in snd $ applyIndentation (IncInline (pointBufSpan 1 inlCol),richTTree)+ insSpan = pointBufSpan 1 (case ai of AdaptIndToTargetEnv -> inlCol+ IgnoreIndOfTargetEnv -> 1)+ in snd $ applyIndentation (IncInline insSpan,richTTree) in produceClientTTree sti fileCache = if occFileName == bindFileName then [( occFileName,str2LineBuf occFileContent)]
Language/Haskell/HBB/Internal/GHCHighlevel.hs view
@@ -39,7 +39,7 @@ import Language.Haskell.HBB.Internal.GHC import Control.Exception (throw,Exception) import Data.Generics-import FastString (mkFastString{-,fsLit-})+import FastString (mkFastString) import Outputable import Data.Maybe (fromJust) import Data.List (sortBy)@@ -105,13 +105,13 @@ -- at the passed location sorted by length in increasing oder. getThingsAt :: (GhcMonad m,Typeable a) - -- | Tells how to extract the span of an a. If the a element is at the+ => (a -> BufLoc -> Maybe BufSpan) + -- ^ Tells how to extract the span of an a. If the a element is at the -- BufLoc specified then the according BufSpan is returned. Note that the -- results are sorted by the end location of the BufSpan that is returned -- here. So if this function returns weird data then the sorting of the -- results is not warranted.- => (a -> BufLoc -> Maybe BufSpan) - -> FilePath -- ^ The filename of the module that should be considered.+ -> FilePath -- ^ The filename of the module to be considered. -> BufLoc -- ^ The required start-location of the tokens. -> m [a] -- ^ A sorted list of results. getThingsAt isAtLoc filename location = do@@ -123,7 +123,7 @@ checkedMod <- searchModGraphFor (Left filename) >>= return . snd >>= parseModule >>= typecheckModule - let (rnSource,_,_,_) = fromJust $ tm_renamed_source checkedMod+ let rnSource = fromJust $ tm_renamed_source checkedMod locateIt s x = case isAtLoc x s of Nothing -> []@@ -150,7 +150,7 @@ (blStart,blEnd) <- case mbBL of Nothing -> do- lexerResult <- getVariableIdUsingLexerAt (filename,loc1) ExcludeQualifiedVars+ lexerResult <- getVariableIdUsingLexerAt (filename,loc1) IncludeQualifiedVars let (_,rSpan) = case lexerResult of Right x -> x Left x -> throw (LexingSearchError x)@@ -322,12 +322,12 @@ data WhatIsAtIndirection = NoRecursion | RecFromName | RecFromSig+ | RecFromIEDecl -- | This function is responsible to detect what kind of thing is located at -- the passed location (the token). whatIsAt :: GhcMonad m - -- => FilePath -- ^ The current working directory (to normalize pathes...) => FilePath -- ^ The file where the token occurred -> BufSpan -- ^ The location of the token to consider -> m WhatIsAt@@ -345,23 +345,37 @@ followName n = case nameSrcSpan n of UnhelpfulSpan _ -> Nothing RealSrcSpan rs -> Just (unpackRealSrcSpan rs)- - tokenIsName <- do - let considerLHsExprVar :: LHsExpr Name -> BufLoc -> Maybe BufSpan- considerLHsExprVar (L (RealSrcSpan r) (HsVar _ )) bl = if (spanStart $ toBufSpan r) == bl- then Just $ toBufSpan r else Nothing- considerLHsExprVar _ _ = Nothing+ let isTokenName :: GhcMonad m => FilePath -> BufLoc -> m WhatIsAt+ isTokenName fn sl = do+ let considerLHsExprVar :: LHsExpr Name -> BufLoc -> Maybe BufSpan+ considerLHsExprVar (L (RealSrcSpan r) (HsVar _ )) bl = if (spanStart $ toBufSpan r) == bl+ then Just $ toBufSpan r else Nothing+ considerLHsExprVar _ _ = Nothing - things <- getThingsAt considerLHsExprVar filename startLoc- case things of- [(L _ (HsVar n))] -> case followName n of- Nothing -> return $ ThereIsAnExternalName n- Just (f,s) -> whatIsAtInternal RecFromName {-cwd-} f s- -- in whatIsAt cwd fn ss- -- return $ ThereIsAName n- _ -> return $ UnknownElement+ things <- getThingsAt considerLHsExprVar fn sl+ case things of+ [(L _ (HsVar n))] -> case followName n of+ Nothing -> return $ ThereIsAnExternalName n+ Just (f,s) -> whatIsAtInternal RecFromName f s+ _ -> return $ UnknownElement + let isTokenIEDecl :: GhcMonad m => FilePath -> BufLoc -> m WhatIsAt+ isTokenIEDecl fn bl = do+ let considerIEDeclAt :: LIE Name -> BufLoc -> Maybe BufSpan+ considerIEDeclAt (L (RealSrcSpan r) (IEVar _)) l = if (spanStart $ toBufSpan r) == l+ then Just $ toBufSpan r else Nothing+ considerIEDeclAt _ _ = Nothing++ things <- getThingsAt considerIEDeclAt fn bl+ case things of+ [(L (RealSrcSpan _) (IEVar n))] -> + case followName n of+ Nothing -> return $ ThereIsAnIEDeclToExtern n+ Just (f,s) -> whatIsAtInternal RecFromIEDecl f s+ _ -> return UnknownElement+ + let isValBindAt :: GhcMonad m => FilePath -> BufLoc -> m WhatIsAt isValBindAt fn sl = do let considerBindsAt :: LHsBindLR Name Name -> BufLoc -> Maybe BufSpan@@ -381,9 +395,10 @@ case funBinds of [b@(L _ (FunBind { fun_id = (L _ _) }))] -> return $- case rec of NoRecursion -> ThereIsABinding b- RecFromName -> ThereIsANameFor (ThereIsABinding b)- RecFromSig -> ThereIsATypeSigFor (ThereIsABinding b)+ case rec of NoRecursion -> ThereIsABinding b+ RecFromName -> ThereIsANameFor (ThereIsABinding b)+ RecFromSig -> ThereIsATypeSigFor (ThereIsABinding b)+ RecFromIEDecl -> ThereIsAnIEDeclFor (ThereIsABinding b) _ -> return $ UnknownElement let isFunParameterAt :: GhcMonad m => FilePath -> BufLoc -> m WhatIsAt@@ -422,9 +437,11 @@ Nothing -> return UnknownElement Just (f,s) -> whatIsAtInternal RecFromSig f s _ -> return UnknownElement- _ -> return UnknownElement- + _ -> return UnknownElement + + tokenIsName <- isTokenName filename startLoc + tokenIsIEDecl <- isTokenIEDecl filename startLoc tokenIsValBind <- isValBindAt filename startLoc tokenIsFunParameter <- isFunParameterAt filename startLoc tokenIsFunSignature <- isFunSignatureAt filename startLoc@@ -433,13 +450,23 @@ orIfUnknown UnknownElement x = x orIfUnknown x _ = x - return $ tokenIsName `orIfUnknown` tokenIsValBind `orIfUnknown` tokenIsFunParameter `orIfUnknown` tokenIsFunSignature+ return $ tokenIsName `orIfUnknown` + tokenIsIEDecl `orIfUnknown` + tokenIsValBind `orIfUnknown` + tokenIsFunParameter `orIfUnknown` + tokenIsFunSignature data WhatIsAt = -- | Names are used for value- and function bindings as well as -- function parameters. External names refer to things outside of -- the module graph (external libraries for example) ThereIsAnExternalName Name+ -- | (I)mport/(E)xport declaration that points to another+ -- compilation unit (package).+ | ThereIsAnIEDeclToExtern Name+ -- | (I)mport/(E)xport declaration that points to the thing+ -- stored as first parameter.+ | ThereIsAnIEDeclFor WhatIsAt -- | Names are just pointers to other things. When such a name is -- discovered, another run of WhatIsAt is triggered which -- searches for the thing that is at the location pointed to by
+ Language/Haskell/HBB/Internal/InterfaceTypes.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS -Wall #-}++module Language.Haskell.HBB.Internal.InterfaceTypes (+ NonFirstLinesIndenting(..)+ ) where+++-- | Instances of this data type control whether the non-first lines of a+-- binding in mode /inline/ or /smart-inline/ should get some extra indentation+-- to match the environment of the place where the binding should be written+-- to.+--+-- Assumed that the following call to /factorial/ should get inlined:+--+-- @+-- result = factorial 3+-- @+--+-- The function /factorial/ looks this way:+--+-- @+-- factorial 1 = 1+-- factorial x = x * factorial (x-1)+-- @+--+-- The lambda function that is produced in mode /inline/ with /IgnoreIndOfTargetEnv/+-- looks as follows:+--+-- @+-- (\x -> case x of 1 -> 1+-- y -> y * factorial (y - 1))+-- @+--+-- The lambda function produced in mode /inline/ with /AdaptIndToTargetEnv/+-- looks as follows:+--+-- @+-- (\x -> case x of 1 -> 1+-- y -> y * factorial (y - 1))+-- @+data NonFirstLinesIndenting = AdaptIndToTargetEnv -- ^ Increase indentation of non-first lines+ -- by the column number the inlined version of the+ -- the function starts at (short: adapt indentation+ -- to caller environment)+ | IgnoreIndOfTargetEnv -- ^ Preserve indentation which means don't adapt+ -- the indentation to the environment of the caller.
Language/Haskell/HBB/Internal/InternalTTree.hs view
@@ -72,7 +72,7 @@ offsetFromContent = elementOffset content in ((insInfo,totalChildOffset+offsetFromContent),TTree content newChilds) --- This function turns the (internal) transformation-tree (with the recursive+-- | This function turns the (internal) transformation-tree (with the recursive -- elements offsets attached) into a transformation-tree the client -- understands. This is mostly a task of making the indentation (which first is -- attached implicitely) explicit which means that each addition begins with@@ -82,17 +82,17 @@ -- therefore 'indentation.markdown' is a concept-paper which describes some -- details with the help of some examples. applyInsertionInfo- :: Indentation -- Element offset of the parent element- -> Indentation -- The recursive element offset of the parent element+ :: Indentation -- ^ Element offset of the parent element+ -> Indentation -- ^ The recursive element offset of the parent element -- if it is of type IncInline or 0 if it is of type -- NewSection- -> [RecElementOffset] -- 'Recursive element offset' of all parents+ -> [RecElementOffset] -- ^ 'Recursive element offset' of all parents -- between the the current element and the root node- -> [AccLevelOffset] -- The accumulated level offset stack- -> [Int] -- Parent elemen trailing chars stack- -> Indentation -- 'Effective indentation' of the parent element- -> Int -- Number of lines in the parent element (for NewSection insertion position)- -> Int -- Number of NewSection childs the parent element has (for NewSection insertion position)+ -> [AccLevelOffset] -- ^ The accumulated level offset stack+ -> [Int] -- ^ Parent elemen trailing chars stack+ -> Indentation -- ^ 'Effective indentation' of the parent element+ -> Int -- ^ Number of lines in the parent element (for NewSection insertion position)+ -> Int -- ^ Number of NewSection childs the parent element has (for NewSection insertion position) -> [((BufSpan ,RecElementOffset),ClientTTree )] -> ((InsertionInfo,RecElementOffset),TTree LineBuf RealSrcSpan (InsertionInfo,RecElementOffset)) -> [((BufSpan ,RecElementOffset),ClientTTree )]@@ -132,13 +132,18 @@ let (BufSpan (BufLoc _ c1) (BufLoc _ _)) = bs in (c1-1) + (sum samLvl_recElemOffsetStack) + parent_EffectiveIndentation ++ newSectionChildsIndentation = (sum $ currentAccLevelOffset:parent_accLevelOffsetStack) -+ (sum $ currentElemParentElemTrailingchars:parent_parentElemTrailingCharsStack) ++ curElemRecElemOffs+ --(elementOffset content)+ ------------------------------------------------------------------- -- TRACING ------------------------------------------------------------------- - shouldTrace = case _content of (Addition ["somefunction"]) -> False - (Display spn) -> (srcSpanStartLine spn == 2) && (srcSpanStartCol spn == 5)- _ -> False+ shouldTrace = case _content of (Addition ["in "]) -> False+ _ -> False txt = case currentElementsInsertionInfo of (NewSection n) -> "NewSection " ++ (show n) ++ " -> " ++ msgContentTxt ++ "\n" ++@@ -162,7 +167,8 @@ ," calced eff. indentation: " ++ (show currentEffInd) ," parent accumulat. level offset stack: " ++ (show parent_accLevelOffsetStack) ," current level accum. level offset: " ++ (show currentAccLevelOffset)- ," parent element trailing chars: " ++ (show parent_parentElemTrailingCharsStack)]+ ," parent element trailing chars: " ++ (show parent_parentElemTrailingCharsStack)+ ," indentation of NewSection childs: " ++ (show newSectionChildsIndentation)] content = if not shouldTrace then _content else trace ("/* applyInsertionInfo with " ++ txt ++ " */") _content@@ -175,11 +181,6 @@ newSecChilds = [ c | c@((NewSection _,_),_) <- childs ] otherChilds = [ c | c@((IncInline _,_),_) <- childs ]-- newSectionChildsIndentation = (sum $ currentAccLevelOffset:parent_accLevelOffsetStack) -- (sum $ currentElemParentElemTrailingchars:parent_parentElemTrailingCharsStack) +- curElemRecElemOffs- --(elementOffset content) newSecChildsAdditionalLines = -- As described in 'indentation.markdown' a NewSections indentation@@ -198,39 +199,15 @@ (Addition ad) -> length ad (Display spn) -> srcSpanEndLine spn - srcSpanStartLine spn + 1 + -- This is the insertion position within the parent element. For+ -- elements of type IncInline the BufSpan is adapted by the parent. For+ -- NewSection elements the parent prepared the indentation and the+ -- insertion position is at the end of this indentation. insertionPosWithinParent = - let colAddedPart = sum parent_accLevelOffsetStack- colSubtractedPart = sum parent_parentElemTrailingCharsStack- in case currentElementsInsertionInfo of- -- We have a NewSection element. From the parent- -- element we know the number of lines it has. As- -- the NewSection lines are always the last ones,- -- we are able to detect on which line we should- -- be inserted.- --- -- NewSection elements insertion column- -- ------------------------------------- --- -- The insertion position of NewSection elements is a little- -- tricky. In case of IncInline the positions are adapted by- -- the parent elements but for NewSection the indentation- -- of the parent element must be considered as well.- --- -- First NewSection within parent:- -- <parent effective indentation> + parent_elemOffset + 1- -- Non-First NewSection within parent:- -- <parent effective indentation> + parent_recElemOffset + 1- --- -- The second part adds the insertion position within the- -- parent element (NewSection are always inserted at the end- -- but non-first lines are indented with the effective- -- indentation).- (NewSection 1) -> pointBufSpan - (nrOfLinesInParentElement - (nrOfNewSectionChildsInParent - 1)) - (colAddedPart - colSubtractedPart + parent_elemOffset + 1)+ case currentElementsInsertionInfo of (NewSection idx) -> pointBufSpan (nrOfLinesInParentElement - (nrOfNewSectionChildsInParent - idx)) - (colAddedPart - colSubtractedPart + parent_recElemOffset + 1)+ (currentEffInd + 1) (IncInline bs) -> bs -- Recursion function@@ -268,15 +245,9 @@ let addIndentation :: LineBuf -> LineBuf addIndentation xs = map (\x -> effectiveIndStr ++ x) xs - baseIndented = case currentElementsInsertionInfo of- -- The first NewSection is appended to the previous- -- element and does not need to be indented...- (NewSection _) -> case ad of [] -> [] - (x:xs) -> x:(addIndentation xs)- -- IncInline elements are written 'inline' which means that- -- the first line of them do not have to be indented- (IncInline _) -> case ad of [] -> []- (x:xs) -> x:(addIndentation xs)+ baseIndented = case ad of [] -> [] + (x:xs) -> x:(addIndentation xs)+ in baseIndented ++ newSecChildsAdditionalLines moveBufSpanByEffInd :: BufSpan -> BufSpan
Language/Haskell/HBB/Internal/InternalTTreeCreation.hs view
@@ -55,7 +55,7 @@ type IsValueBinding = Bool -instance ConvertibleToTTree (IsValueBinding,GRHS Name) where+instance ConvertibleToTTree (IsValueBinding,LGRHS Name,Maybe (HsValBindsLR Name Name)) where -- [Indentation] --@@ -96,7 +96,7 @@ -- x -> x * fact (x-1))) 5 -- - toTTree (isValueBinding,GRHS stmts expr@(L (RealSrcSpan exprLoc) _)) = do+ toTTree (isValueBinding,L _ (GRHS stmts expr@(L (RealSrcSpan _) _)),mbValBinds) = do lambdaStyle <- ask exprsTTree <- local (const ProduceEqual) (toTTree expr) case (isValueBinding,stmts,lambdaStyle) of@@ -106,28 +106,36 @@ - represented by their value. -} return exprsTTree (_ ,[] ,_ ) -> do- let (addition,exprInsPos) = case lambdaStyle of- ProduceLambda -> (["-> "],pointBufSpan 1 4)- ProduceEqual -> (["= "] ,pointBufSpan 1 3)- return $ TTree (Addition addition) [(IncInline exprInsPos,exprsTTree)]+ -- A GRHS without guards.+ let addition = case lambdaStyle of ProduceLambda -> ["-> "]+ ProduceEqual -> ["= "] + case mbValBinds of + Nothing -> return $ TTree (Addition addition) [(NewSection 1,exprsTTree)]+ Just vb -> do whereAsLet <- toTTree vb+ return $ TTree (Addition addition) + [+ (NewSection 1,TTree (Addition ["let "]) [(NewSection 1,whereAsLet)]),+ (NewSection 2,TTree (Addition ["in "]) [(NewSection 1,exprsTTree)])+ ] (_ ,_ ,_ ) -> do+ -- A GRHS with guards. stmtsTTree <- local (const ProduceEqual) (toTTree stmts)- - let stmtsAndExprHaveCommonLine = - any (\(L (RealSrcSpan r) _) -> not $ onDifferentLines exprLoc r) stmts - (addition,exprInsPos) = case (lambdaStyle,stmtsAndExprHaveCommonLine) of- (ProduceLambda,True ) -> (["| -> "] ,pointBufSpan 1 7)- (ProduceLambda,False) -> (["| ->"," "],pointBufSpan 2 5)- (ProduceEqual ,True ) -> (["| = "] ,pointBufSpan 1 6)- (ProduceEqual ,False) -> (["| =", " "],pointBufSpan 2 5)- return $ TTree (Addition addition) [(IncInline $ pointBufSpan 1 3,stmtsTTree)- ,(IncInline exprInsPos ,exprsTTree)]- toTTree _ = error "internal error (unexpected unhelpful src-loc in expr)"-+ let addition = case lambdaStyle of ProduceLambda -> ["| -> "]+ ProduceEqual -> ["| = " ] -instance ConvertibleToTTree (IsValueBinding,LGRHS Name) where- toTTree (isValueBinding,L _ g) = toTTree (isValueBinding,g)+ case mbValBinds of+ Nothing -> return $ TTree (Addition addition) + [(IncInline $ pointBufSpan 1 3,stmtsTTree)+ ,(NewSection 1 ,exprsTTree)]+ Just vb -> do whereAsLet <- toTTree vb+ return $ TTree (Addition addition) + [+ (IncInline $ pointBufSpan 1 3,stmtsTTree),+ (NewSection 1 ,TTree (Addition ["let "]) [(NewSection 1,whereAsLet)]),+ (NewSection 2 ,TTree (Addition ["in "]) [(NewSection 1,exprsTTree)])+ ]+ toTTree _ = error "internal error (unexpected unhelpful src-loc in expr)" combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan combineRealSrcSpans s1 s2 = @@ -173,22 +181,39 @@ in return $ TTree (Display asSingleSpan) [] --topLevelAddition +-- | HsLocalBinds is for example use for "where" clauses+--+-- TODO is this still needed? instance ConvertibleToTTree (HsLocalBinds Name) where toTTree EmptyLocalBinds = return $ TTree (Addition [""]) []- toTTree (HsIPBinds _) = error "What is IP-Binds?" -- TODO is this case relevant?+ toTTree (HsIPBinds _) = error "What is IP-Binds?" toTTree (HsValBinds vb) = toTTree vb -instance ConvertibleToTTree (IsValueBinding,GRHSs Name) where- toTTree (_,GRHSs { grhssGRHSs = [] }) = error "internal error (expected at least one grhs)"+instance ConvertibleToTTree (IsValueBinding,GRHSs Name,LambdaNotationStyle) where+ toTTree (_,GRHSs { grhssGRHSs = [] },_) = error "internal error (expected at least one grhs)" toTTree (isValueBinding ,GRHSs { grhssGRHSs = content- , grhssLocalBinds = whereCl } ) = do+ , grhssLocalBinds = whereCl }+ ,notationStyle) = do++ whatToProduce <- ask++ -- If the value whereClAsLet is 'Nothing' then+ -- there is either no where clause or it doesn't+ -- need to be converted to a 'let' expression.+ let whereClAsLet = case (notationStyle,whatToProduce,whereCl) of + (_ ,ProduceEqual ,HsValBinds _) -> Nothing+ (ShortNotationStyle ,ProduceLambda,HsValBinds vb) -> Just vb+ (LongNotationWithWhere,ProduceLambda,HsValBinds _) -> Nothing+ (_ ,_ ,HsIPBinds _) -> error "Internal error (what is IPBinds)?"+ (_ ,_ ,EmptyLocalBinds) -> Nothing+ grhssAsNewSections <- do let arg :: ((Int,Int),[(InsertionInfo,InternalTTree)] ) -> LGRHS Name -> Reader ConversionInfo ((Int,Int),[(InsertionInfo,InternalTTree)] ) arg ((pos,tot),acc) grhs = do- tr <- toTTree (isValueBinding,grhs)+ tr <- toTTree (isValueBinding,grhs,whereClAsLet) let insPos = NewSection pos return $ ((pos+1,tot),(insPos,tr):acc) (_,res) <- foldM arg ((1,length content),[]) content@@ -197,14 +222,26 @@ let grhssAsTree :: InternalTTree grhssAsTree = TTree (Addition [""]) grhssAsNewSections - case whereCl of- HsIPBinds _ -> error "what is HsIPBinds?"- EmptyLocalBinds -> return $ grhssAsTree- HsValBinds vb -> do+ case (whereCl,whereClAsLet) of+ (HsIPBinds _,_) -> error "what is HsIPBinds?"+ (EmptyLocalBinds,_) -> return $ grhssAsTree++ -- !! TODO "where" clauses need to distinct ProduceEqual (where+ -- they are written as they are) and ProduceLambda (where they need+ -- to be converted to a lambda function)!!++ (HsValBinds vb,Nothing) -> do+ -- There are "where" statements which are not converted to a+ -- "let" expression (for example if ProduceEqual is passed).+ -- So we have to add one... whereTree <- toTTree vb return $ TTree (Addition [""]) [(NewSection 1,grhssAsTree) ,(NewSection 2,TTree (Addition ["where" ," "]) [(NewSection 1,whereTree)])]+ (HsValBinds _,Just _) -> do+ -- In this case the "where" has been turned to a "let"+ -- expression and doesn't need to be treated at this point...+ return $ grhssAsTree {- - [Value bindings]@@ -231,9 +268,12 @@ - | otherwise = sin {- sine from prelude -} -} -instance ConvertibleToTTree ([LPat Name],(GRHSs Name)) where- toTTree (patterns,grhss) = do+data LambdaNotationStyle = ShortNotationStyle -- ^ may convert a where-expression to a let-expression+ | LongNotationWithWhere +instance ConvertibleToTTree ([LPat Name],(GRHSs Name),LambdaNotationStyle) where+ toTTree (patterns,grhss,notationStyle) = do+ -- Patterns in ordinary functions are given in the form <first elem> -- <second elem> (space separated). When converting to a lambda -- function the pattern must have the form (<first elem>,<second elem>)@@ -276,7 +316,7 @@ _ -> "(" ++ (replicate ((length patterns) - 1) ',') ++ ")" in TTree (Addition [topLvlAddition]) childs let isValueBinding = (length patterns) == 0- grhssTree <- toTTree (isValueBinding,grhss)+ grhssTree <- toTTree (isValueBinding,grhss,notationStyle) return $ case isValueBinding of False -> TTree (Addition [" "]) [(IncInline $ pointBufSpan 1 1,stmtsTree) ,(IncInline $ pointBufSpan 1 2,grhssTree)]@@ -292,14 +332,39 @@ let (L _ (Match pttrns _ _)) = firstMatch in length pttrns - -- Prefix example: \a b c -> case (a,b,c) of + -- Prefix example: "\a b c -> case (a,b,c) of" with content: "(x,y,z) | guards ->" - prefix = case nrOfParameters of+ -- There is one special case where the prefix of a function binding+ -- can be written as "\x y z ->" which means that the "case" can be+ -- omitted. Following conditions must hold for this:+ -- - The function must have only one match.+ -- - Content mustn't have a guard.+ -- - There mustn't be a "where" clause.+ -- + -- If all these conditions hold then the short notation can be+ -- applied savely. However a "where" clause can also be converted+ -- to a "let" expression which might make sense in a function with+ -- only a single match. This is the behaviour that is currently+ -- implemented.++ isGuarded :: LMatch Name -> Bool+ isGuarded (L _ (Match _ _ (GRHSs { grhssGRHSs = grhss }))) = any isGuardedGRHS grhss+ where isGuardedGRHS :: LGRHS Name -> Bool+ isGuardedGRHS (L _ (GRHS [] _)) = False+ isGuardedGRHS _ = True++ notationStyle = case (whatToProduce,any isGuarded matches,length matches) of+ (ProduceLambda,False,1) -> ShortNotationStyle+ _ -> LongNotationWithWhere++ prefix = case (nrOfParameters,notationStyle) of -- Have a look at the comment [Bindings with zero matches] for -- examples of zero-parameter bindings that should be -- supported.- 0 -> "" - 1 -> "\\a -> case a of "+ (0,_ ) -> "" -- This is a value binding...+ (_,ShortNotationStyle ) -> "\\" -- This is a function without guards and only a single match which+ -- can be written shorter...+ (1,LongNotationWithWhere) -> "\\a case a of " _ -> let caseParameters = take nrOfParameters ['a'..] in "\\" ++ (intersperse ' ' caseParameters) ++ " -> case (" ++ (intersperse ',' caseParameters) ++ ") of "@@ -310,7 +375,7 @@ -> Reader ConversionInfo ((Int,Int),[(InsertionInfo,InternalTTree)]) matches2lambda ((nr,tot),acc) (L _ (Match patterns _ grhss)) = do - innerTree <- toTTree (patterns,grhss)+ innerTree <- toTTree (patterns,grhss,notationStyle) return $ case whatToProduce of ProduceEqual ->
Language/Haskell/HBB/Internal/SrcSpan.hs view
@@ -2,10 +2,9 @@ {-# OPTIONS -Wall #-} module Language.Haskell.HBB.Internal.SrcSpan where -import System.Directory (canonicalizePath) import System.FilePath (normalise,makeRelative) import Data.Generics-import FastString (unpackFS)+import FastString (unpackFS,fsLit) import Data.Char (isSpace) import SrcLoc @@ -45,6 +44,13 @@ unpackRealSrcSpan :: RealSrcSpan -> (FilePath,BufSpan) unpackRealSrcSpan r = (unpackFS $ srcSpanFile r,toBufSpan r) +packRealSrcSpan :: (FilePath,BufSpan) -> RealSrcSpan+packRealSrcSpan (f,(BufSpan (BufLoc l1s l1e) (BufLoc l2s l2e))) =+ let newFilename = fsLit f+ in mkRealSrcSpan+ (mkRealSrcLoc newFilename l1s l1e)+ (mkRealSrcLoc newFilename l2s l2e)+ normalisePath :: FilePath -- ^ The current working dir (to make pathes relative) -> FilePath -- ^ The path that should be adapted@@ -55,11 +61,12 @@ -- string. The string has the format that is used by 'occurrences-of' and -- 'locate' to report locations to the client. showSpan - :: FilePath -- ^ The current working dir (to make pathes relative)+ :: Maybe FilePath -- ^ The current working dir (to force relative pathes) -> (FilePath,BufSpan) -- ^ The location to convert to a string -> String showSpan cwd (f,(BufSpan (BufLoc sli sco) (BufLoc eli eco))) =- let filePart = normalisePath cwd f+ let filePart = case cwd of Nothing -> f+ Just c -> normalisePath c f in ('"':filePart ++ "\"") ++ (' ':(show sli)) ++ (' ':(show sco)) ++ (' ':(show eli)) ++ (' ':(show eco))
Language/Haskell/HBB/Locate.hs view
@@ -11,8 +11,10 @@ import Language.Haskell.HBB.Internal.GHCHighlevel import Language.Haskell.HBB.Internal.SrcSpan import Language.Haskell.HBB.Internal.GHC+import System.Directory (getCurrentDirectory) import FastString (unpackFS) import GHC.Paths (libdir)+import GhcMonad (liftIO) import SrcLoc import GHC (GhcMonad) @@ -38,16 +40,17 @@ -- The string has exactly the format that should be understood by text editors -- that are using the mode locate. showLocateResult - :: FilePath -- ^ The current working dir (to make pathes relative)- -> (FilePath,BufSpan) -- ^ The position that should be converted to string+ :: (FilePath,BufSpan) -- ^ The position that should be converted to string -> String-showLocateResult cwd loc = showSpan cwd loc+showLocateResult loc = showSpan Nothing loc -- | This is a variant of locate that runs within the GHC monad and therefore -- allows a more fine-grained control over the behaviour of GHC. locateM :: GhcMonad m => FilePath -> BufLoc -> m (FilePath,BufSpan) locateM filename reqLoc = do + cwd <- liftIO $ getCurrentDirectory+ (SearchedTokenInfo { result = (searchedBinding,sig) }) <- searchFunctionBindingM filename reqLoc Nothing -- -- The mode locate is only able to return one (single) source range.@@ -66,5 +69,5 @@ then BufSpan (BufLoc sl sc) end else toBufSpan bindLoc Just _ -> toBufSpan bindLoc- bindingFile = unpackFS $ srcSpanFile bindLoc+ bindingFile = normalisePath cwd $ unpackFS $ srcSpanFile bindLoc return (bindingFile,r)
Language/Haskell/HBB/OccurrencesOf.hs view
@@ -72,14 +72,13 @@ -- | This Function formats the results from the occurrencesOf or occurrencesOfM -- function. showOccurrencesOfResult - :: FilePath -- ^ The current working dir (to make pathes relative)- -> [(FilePath,BufSpan)] -- ^ The result that should be shown+ :: [(FilePath,BufSpan)] -- ^ The result that should be shown -> String-showOccurrencesOfResult cwd elems = sOORAcc cwd [] elems+showOccurrencesOfResult elems = sOORAcc [] elems where- sOORAcc :: FilePath -> [String] -> [(FilePath,BufSpan)] -> String- sOORAcc _ acc [] = unlines $ reverse acc- sOORAcc c acc (e:r) = sOORAcc c ((showSpan c e):acc) r+ sOORAcc :: [String] -> [(FilePath,BufSpan)] -> String+ sOORAcc acc [] = unlines $ reverse acc+ sOORAcc acc (e:r) = sOORAcc ((showSpan Nothing e):acc) r -- | This function detects what is at the position specified (the token) and -- according to this information it searches all references to this thing.@@ -100,7 +99,7 @@ referrers <- foldM (accumulateThingsThatRefer n) [] (bindingFile `union` [occFile] `union` otherFiles)- definitions <- return $ realSrcSpansOfBinding {-cwd-} (c2 - c1) bind+ definitions <- return $ realSrcSpansOfBinding (c2 - c1) bind return $ definitions ++ referrers @@ -139,8 +138,11 @@ what <- whatIsAt occFile spn - case what of+ locs <- case what of ThereIsAnExternalName _ -> error $ "The token is referring to external functionality"+ ThereIsAnIEDeclToExtern _ -> error $ "Import/Export declaration is referring to external functionality"+ ThereIsAnIEDeclFor (ThereIsABinding b) -> processTokenAsBinding b+ ThereIsAnIEDeclFor _ -> error "Internal error (unexpected reference to non-binding in IEDecl)" ThereIsANameFor (ThereIsABinding b) -> processTokenAsBinding b ThereIsANameFor (ThereIsAFunParameter p) -> processTokenAsFunParam p ThereIsANameFor _ -> error "Internal error (the name is referencing unexpected things)"@@ -152,7 +154,15 @@ -- the lexer function will throw if it doesn't find -- a qualified or non-qualified variable. error $ "Unsupported operation. " ++ - "Currently only names for bindings and function parameters are supported."+ "Currently only names for bindings and function parameters are supported.\n" +++ "Moreover the infix notation in function definitions isn't supported either"++ let normaliseRealSrcSpan :: RealSrcSpan -> RealSrcSpan+ normaliseRealSrcSpan r = + let (f,bs) = unpackRealSrcSpan r+ in packRealSrcSpan (normalisePath cwd f,bs)++ return $ map normaliseRealSrcSpan locs -- | This function searches the passed file for variables, import- or export- -- declarations that refer to the name passed as first parameter.@@ -186,16 +196,16 @@ referrers :: [RealSrcSpan] referrers =- let getReferrerFromIE :: Name -> LIE Name -> [RealSrcSpan]- getReferrerFromIE refName (L (RealSrcSpan r) (IEVar n)) | (refName == n) = [r]- getReferrerFromIE _ _ = []+ let getReferrersFromIE :: Name -> LIE Name -> [RealSrcSpan]+ getReferrersFromIE refName (L (RealSrcSpan r) (IEVar n)) | (refName == n) = [r]+ getReferrersFromIE _ _ = [] - getReferrerFromTypeSig :: Name -> Sig Name -> [RealSrcSpan]- getReferrerFromTypeSig refName (TypeSig lNames _) =+ getReferrersFromTypeSig :: Name -> Sig Name -> [RealSrcSpan]+ getReferrersFromTypeSig refName (TypeSig lNames _) = case filter (\(L _ x) -> x == refName) lNames of [L (RealSrcSpan r) _] -> [r] _ -> []- getReferrerFromTypeSig _ _ = []+ getReferrersFromTypeSig _ _ = [] getReferrersFromExprs :: Name -> LHsExpr Name -> [RealSrcSpan] getReferrersFromExprs refName (L (RealSrcSpan r) (HsVar n)) | (refName == n) = @@ -205,9 +215,9 @@ getReferrersFromExprs _ _ = [] genericQuery :: GenericQ [RealSrcSpan]- genericQuery = mkQ [] (getReferrerFromIE defName) `extQ` - (getReferrerFromTypeSig defName) `extQ`- (getReferrersFromExprs defName)+ genericQuery = mkQ [] (getReferrersFromIE defName) `extQ` + (getReferrersFromTypeSig defName) `extQ`+ (getReferrersFromExprs defName) in queryRenamedAST [] (++) genericQuery renSource
Language/Haskell/HBB/SmartInline.hs view
@@ -5,6 +5,7 @@ smartinlineM, showSmartInlineResult, showSmartInlineResultAsByteString,+ NonFirstLinesIndenting(..), BufLoc(..), BufSpan(..), RealSrcSpan(..),@@ -15,6 +16,7 @@ ) where import Language.Haskell.HBB.Internal.InternalTTreeCreation+import Language.Haskell.HBB.Internal.InterfaceTypes import Language.Haskell.HBB.Internal.InternalTTree import Language.Haskell.HBB.Internal.GHCHighlevel import Language.Haskell.HBB.Internal.TTreeJSON (encodeTTreeToJSON,decodeTTreeFromJSON)@@ -28,6 +30,7 @@ import SrcLoc import GHC (GhcMonad) + -- | This function implements the mode 'smart-inline'. -- -- Smart-inline takes a location or a span within a file which should be a@@ -39,7 +42,7 @@ -- -- > main :: IO () -- > main = do--- > res <- smartinline ["-isrc"] "example/Example.hs" 14 13+-- > res <- smartinline ["-isrc"] IgnoreIndOfTargetEnv "example/Example.hs" (BufLoc 14 13) -- > LazyByteString.putStr $ encodeTTreeToJSON res -- > putStrLn "" --@@ -55,9 +58,10 @@ -- -- - Some options to the mode 'inline' that change the functions behaviour ---smartinline :: [String] -> FilePath -> BufLoc -> Maybe BufLoc -> IO (RealSrcSpan,TTree LineBuf (RealSrcSpan,Int) BufSpan)-smartinline ghcOptions fn sl mbEndLoc = - runGhcWithCmdLineFlags ghcOptions (Just libdir) $ smartinlineM fn sl mbEndLoc+smartinline :: [String] -> NonFirstLinesIndenting -> FilePath -> BufLoc -> Maybe BufLoc + -> IO (RealSrcSpan,TTree LineBuf (RealSrcSpan,Int) BufSpan)+smartinline ghcOptions ai fn sl mbEndLoc = + runGhcWithCmdLineFlags ghcOptions (Just libdir) $ smartinlineM ai fn sl mbEndLoc -- | Converts the result of smartinline and smartinlineM to JSON. --@@ -75,8 +79,9 @@ -- | This function is similar to smartinline except that it runs in a GhcMonad -- instance.-smartinlineM :: GhcMonad m => FilePath -> BufLoc -> Maybe BufLoc -> m (RealSrcSpan,TTree LineBuf (RealSrcSpan,Int) BufSpan)-smartinlineM filename startLoc mbEndLoc = do+smartinlineM :: GhcMonad m => NonFirstLinesIndenting -> FilePath -> BufLoc -> Maybe BufLoc + -> m (RealSrcSpan,TTree LineBuf (RealSrcSpan,Int) BufSpan)+smartinlineM ai filename startLoc mbEndLoc = do sti@(SearchedTokenInfo { result = (binding,_) }) <- searchFunctionBindingM filename startLoc mbEndLoc @@ -84,6 +89,8 @@ produceClientTTree bi = let richTTree = runReader (toTTree $ binding) ProduceLambda inlCol = ((srcLocCol $ realSrcSpanStart $ occSpan bi))- in snd $ applyIndentation (IncInline (pointBufSpan 1 inlCol),richTTree)+ insSpan = pointBufSpan 1 (case ai of AdaptIndToTargetEnv -> inlCol + IgnoreIndOfTargetEnv -> 1)+ in snd $ applyIndentation (IncInline insSpan,richTTree) return (occSpan sti,produceClientTTree sti)
+ Language/Haskell/HBB/TestModes/ApplyTTree.hs view
@@ -0,0 +1,61 @@+++module Language.Haskell.HBB.TestModes.ApplyTTree (+ ApplyTTreeArgs(..),+ defaultApplyTTreeArgs,+ testModeApplyTTree+ ) where++import Language.Haskell.HBB.Internal.TTreeColor+import Language.Haskell.HBB.Internal.TTreeJSON+import Language.Haskell.HBB.Internal.SrcSpan+import Language.Haskell.HBB.Internal.TTree+import qualified Data.ByteString.Char8 as StrictByteString+import System.Environment (getArgs)+import Data.Generics+import FastString (unpackFS,mkFastString)+import Data.List (sortBy,union)+import SrcLoc++-- | This type is used to have influence on the processing of+-- testModeApplyTTree. It is possible to activate ANSI color escape sequences+-- for the text or to enable the printing of the file context.+data ApplyTTreeArgs = ApplyTTreeArgs { applyToShowContext :: Bool+ , applyToShowAnsiColored :: Bool }++-- | These are the default options used for this mode.+-- libhbb-cli only uses these default settings.+defaultApplyTTreeArgs :: ApplyTTreeArgs+defaultApplyTTreeArgs = ApplyTTreeArgs { applyToShowContext = False , applyToShowAnsiColored = False }+++-- | This function reads a transformation-tree serialized to JSON from standard+-- input and applies it which means that it converts it to text. After having+-- it applied the text is returned as one single string.+testModeApplyTTree :: ApplyTTreeArgs -> IO String+testModeApplyTTree options = do+ jsonString <- StrictByteString.getContents+ case decodeTTreeFromJSON jsonString of+ Left msg -> fail $ "Failure reading TTree from stdin: " ++ msg+ Right tree -> applyTTree' options tree+ +-- | This is a helper function for testModeApplyTTree which does most of the+-- work.+applyTTree' :: ApplyTTreeArgs -> (RealSrcSpan,ClientTTree) -> IO String+applyTTree' + (ApplyTTreeArgs { applyToShowContext = sc , applyToShowAnsiColored = sa })+ (spn,tree) = do + let occFile = unpackFS $ srcSpanFile spn+ occFileContent <- readFile occFile+ let affectedNames = [occFile] `union` collectFilenames (toBufSpan spn,tree)+ fileCache <- cacheFiles affectedNames+ let alteredContent = case sc of+ True -> + let lns = lines occFileContent+ in case sa of+ True -> applyColoredTTree fileCache (toBufSpan spn,tree) lns+ False -> applyTTree fileCache (toBufSpan spn,tree) lns+ False -> case sa of+ True -> applyColoredTTree fileCache (pointBufSpan 1 1,tree) [""]+ False -> applyTTree fileCache (pointBufSpan 1 1,tree) [""]+ return $ unlines alteredContent
− README.md
@@ -1,16 +0,0 @@-# **hbb**: Extraordinary Haskell programming--This project aims to create a tool which should be easily embeddable in text-editors to assist them to provide extraordinary editing features for the-Haskell programming language. To archieve this, the tool is based on the-library of the Glasgow Haskell Compiler (GHC).--The name **hbb** is short for *h*askell *b*usy *b*ee and should remind one of-the programmers using it. It consists of the library *hbb* and a command line-tool which has the name *hbb-simple-cli*. *hbb-simple-cli* has been chosen-because in another repository the features of (the library) *hbb* and *ghc-mod*-are merged into an executable *hbb* which provides (many more) features than-*hbb-simple-cli*.--One outstanding feature of *hbb* is is the possibility to inline a function-binding.
− editor-plugin/vim/hbb.vim
@@ -1,59 +0,0 @@--:let g:hbb_executable_name = "hbb"--" ghc options must be written in the same way they are passed to hbb which-" means that each option must be prepended by '-g'. For example-" let g:hbb_ghc_options = '-g -isrc -g -packageghc -g -XFlexibleInstances'-:let g:hbb_ghc_options = ""--" This function inlines the currently selected function or prints an error-" message if inlining fails.-" If any argument is passed then the file is saved after inlining.-function! HBBInlineSelection( ... )- :let curline = getline('.')- :let startpos = getpos( "'<" )- :let endpos = getpos( "'>" )- :let curfile = expand('%')- :let commandstr = g:hbb_executable_name . " " . g:hbb_ghc_options . " inline " . curfile . " " . startpos[1] . " " . startpos[2] . " " . endpos[1] . " " . (endpos[2] + 1) . " 2>./.vim-hbb.log"- :let fun = system( commandstr )- :let errorreason = readfile( "./.vim-hbb.log" ) - :call delete("./.vim-hbb.log")- :if len( fun ) == 0- :let errorreason_copy = copy( errorreason )- :let errorreason_copy[0] = "Inlining failed: " . errorreason[0]- :echo join( errorreason_copy , "\n" )- :else- :let funnamelen = endpos[2] - startpos[2] + 1-- :if startpos[2] < 2- :let curlineprefix = ""- :else- :let curlineprefix = curline[0:(startpos[2]-2)]- :endif- :let curlinesuffix = curline[startpos[2]+funnamelen-1:]- :let content2insertAsList = split( fun , '\n' )- :let firstlineEnd = content2insertAsList[0]- :let lastlineStart = content2insertAsList[-1]- :if len( content2insertAsList ) >= 2- " This is a multiline entry...- :call remove( content2insertAsList , 0 )- :call remove( content2insertAsList , len( content2insertAsList ) - 1 )- :call insert( content2insertAsList , curlineprefix . firstlineEnd )- :call add( content2insertAsList , lastlineStart . curlinesuffix )- :else- " This is a single-line entry...- :let content2insertAsList[0] = curlineprefix . content2insertAsList[0] . curlinesuffix- :endif- :call setline( '.' , content2insertAsList[0] )- :call append( line('.') , content2insertAsList[1:] )-- :if len( a:000 ) != 0- :w- :endif-- :endif- :call setpos( '.' , startpos )-endfunction--":vmap i :call HBBInlineSelection()<CR>-":vmap I :call HBBInlineSelection( "with saving" )<CR>
libhbb.cabal view
@@ -9,7 +9,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.3.0.0+version: 0.4.0.0 -- A short (one-line) description of the package. synopsis: Backend for text editors to provide better Haskell editing support.@@ -22,7 +22,7 @@ completely independent of ghc-mod. The connection to ghc-mod is established in a package called hbb. The features of libhbb can be used standalone by the means of- the executable hbb-simple-cli which is sipped as well.+ the executable libhbb-cli which is sipped as well. The big outstanding feature that libhbb provides is the ability to inline functions (their body is converted to a@@ -55,21 +55,17 @@ -- Constraint on the version of Cabal needed to build this package. cabal-version: >= 1.8 -extra-source-files: README.md- editor-plugin/vim/hbb.vim- source-repository head type: git location: https://bitbucket.org/bhris/libhbb.git --- This executable is named 'hbb-simple-cli' because it is a simple command--- line client providing the features exposed by the library. There is also --- an executable 'hbb' in another project which integrates the features of+-- This executable 'libhbb-cli' exposes the features of the library. There is+-- also an executable 'hbb' in another project which integrates the features of -- 'ghc-mod' and 'libhbb' and therefore has much more features (as well as -- cabal integration)-executable hbb-simple-cli+executable libhbb-cli -- .hs or .lhs file containing the Main module.- main-is: HBBSimpleCLI.hs+ main-is: LibHbbCli.hs --Default-Language: Haskell2010 @@ -78,10 +74,11 @@ -- Default-Extensions: ConstraintKinds, FlexibleContexts -- Other library packages from which modules are imported.- build-depends: base == 4.* , libhbb >= 0.2, bytestring >= 0.10, directory >= 1.2+ build-depends: base == 4.* , libhbb == 0.4.*, bytestring >= 0.10, directory >= 1.2 library exposed-modules: Language.Haskell.HBB.Internal.InternalTTreeCreation+ Language.Haskell.HBB.Internal.InterfaceTypes Language.Haskell.HBB.Internal.InternalTTree Language.Haskell.HBB.Internal.GHCHighlevel Language.Haskell.HBB.Internal.TTreeColor@@ -91,6 +88,7 @@ Language.Haskell.HBB.Internal.Lexer Language.Haskell.HBB.Internal.GHC Language.Haskell.HBB.Internal.AST+ Language.Haskell.HBB.TestModes.ApplyTTree Language.Haskell.HBB.OccurrencesOf Language.Haskell.HBB.SmartInline Language.Haskell.HBB.ExprType
− src/HBBSimpleCLI.hs
@@ -1,93 +0,0 @@-{-# OPTIONS -Wall #-}--module Main where--import Language.Haskell.HBB.OccurrencesOf-import Language.Haskell.HBB.SmartInline-import Language.Haskell.HBB.ExprType-import Language.Haskell.HBB.ApplyTo-import Language.Haskell.HBB.Locate-import Language.Haskell.HBB.Inline-import qualified Data.ByteString.Lazy.Char8 as LB-import System.Console.GetOpt as O-import System.Environment (getArgs)-import System.Directory (getCurrentDirectory)-import System.Exit (exitFailure)-import System.IO---usageStr :: String-usageStr = unlines- ["Usage:"- ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] locate <filename> <line> <column>"- ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] inline [--print-context|--with-color] <filename> <line> <column> [<line> <column>]"- ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] smart-inline <filename> <line> <column> [<line> <column>]"- ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] occurrences-of <filename> <line> <column> [<filename> ...]"- ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] exprtype <filename> <expression>"- ,"hbb-simple-cli apply-to [-q] <function of type string to string> <string>"]--data OperationMode = ModeInline InlineOptions- | ModeSmartInline- | ModeLocate- --- | This function is responsible to parse the optional parameters (called--- options). If there is a parameter that doesn't match an option this function--- stops and returns its accumulated result. The extraneous arguments then will--- be the description of the file and the line.-takeOptions :: ([String],InlineOptions) -> ([String],InlineOptions)-takeOptions (("--print-context":rest),ops) = takeOptions (rest,(ops { showContext = True }))-takeOptions (("--with-color" :rest),ops) = takeOptions (rest,(ops { showAnsiColored = True }))-takeOptions x@(_,_) = x--main :: IO ()-main = do- programArgs <- getArgs-- cwd <- getCurrentDirectory-- -- First we want to filter out the options that GHC needs- let (ghcOptions,otherArgs) = - let optdescr :: [OptDescr String]- optdescr = [Option ['g'] [] (ReqArg id "ghc-option") "options passed to ghc"]- in case O.getOpt RequireOrder optdescr programArgs of- (_,_,(_:_)) -> error "Wrong usage of ghc-specific options (every -g must be followed by a GHC option)"- (g,o,[] ) -> (g,o)-- putApplyToResult :: Bool -> (String,Maybe String) -> IO ()- putApplyToResult False (res,Just wa) = do hPutStr stderr wa - hPutStrLn stderr "> "- hPutStrLn stderr "> Pass the flag '-q' to suppress this warning!"- putApplyToResult False (res,Nothing)- putApplyToResult True (res,Just wa) = hPutStr stderr wa >> putApplyToResult True (res,Nothing)- putApplyToResult _ (res,Nothing) = putStr res-- case (ghcOptions,otherArgs) of- (_ ,("occurrences-of":f:l:c:others)) -> occurrencesOf ghcOptions f (BufLoc (read l) (read c)) others >>= putStr . (showOccurrencesOfResult cwd)- (_ ,["exprtype",f,expr]) -> exprtype ghcOptions f expr >>= putStrLn . showExprTypeResult- ([],["apply-to","-q",f,str ]) -> applyTo True f str >>= putApplyToResult True- ([],["apply-to", f,str ]) -> applyTo False f str >>= putApplyToResult False- (_ ,("apply-to":_)) -> error "Mode 'applyto' doesn't allow to specify ghc options (with -g)"- _ -> do- (opMode,occFilename,loc1,maybeLoc2) <- do- case otherArgs of- ["locate" ,f,l,c] -> return (ModeLocate ,f,(BufLoc (read l::Int) (read c::Int)),Nothing)- ("smart-inline":rest) -> - case rest of- (f:sl:sc:el:ec:[]) -> return (ModeSmartInline,f,(BufLoc (read sl::Int) (read sc::Int)),- (Just $ BufLoc (read el::Int) (read ec::Int)))- (f:sl:sc:[]) -> return (ModeSmartInline,f,(BufLoc (read sl::Int) (read sc::Int)),Nothing)- _ -> do putStrLn "Invalid parameters."- putStrLn usageStr; exitFailure- ("inline":rest) -> do- let (locspec,options) = takeOptions (rest,defaultInlineOptions)- case locspec of- (f:sl:sc:el:ec:[]) -> return (ModeInline options,f,(BufLoc (read sl::Int) (read sc::Int)),- (Just $ BufLoc (read el::Int) (read ec::Int)))- (f:sl:sc:[]) -> return (ModeInline options,f,(BufLoc (read sl::Int) (read sc::Int)),Nothing)- _ -> do putStrLn "Invalid parameters."- putStrLn usageStr; exitFailure- _ -> do putStrLn usageStr; exitFailure- case opMode of- ModeInline options -> inline ghcOptions options occFilename loc1 maybeLoc2 >>= putStrLn . showInlineResult- ModeSmartInline -> smartinline ghcOptions occFilename loc1 maybeLoc2 >>= LB.putStr . showSmartInlineResultAsByteString- ModeLocate -> locate ghcOptions occFilename loc1 >>= putStrLn . (showLocateResult cwd)
+ src/LibHbbCli.hs view
@@ -0,0 +1,108 @@+{-# OPTIONS -Wall #-}++module Main where++import Language.Haskell.HBB.TestModes.ApplyTTree+import Language.Haskell.HBB.OccurrencesOf+import Language.Haskell.HBB.SmartInline+import Language.Haskell.HBB.ExprType+import Language.Haskell.HBB.ApplyTo+import Language.Haskell.HBB.Locate+import Language.Haskell.HBB.Inline+import qualified Data.ByteString.Lazy.Char8 as LB+import System.Console.GetOpt as O+import System.Environment (getArgs)+import System.Exit (exitFailure)+import System.IO+++usageStr :: String+usageStr = unlines+ ["Usage:"+ ,"libhbb-cli [-g ghcOpt ...] locate <filename> <line> <column>"+ ,"libhbb-cli [-g ghcOpt ...] inline <inline-opts> <filename> <line> <column> [<line> <column>]"+ ,"libhbb-cli [-g ghcOpt ...] smart-inline [--adapt-ind] <filename> <line> <column> [<line> <column>]"+ ,"libhbb-cli [-g ghcOpt ...] occurrences-of <filename> <line> <column> [<filename> ...]"+ ,"libhbb-cli [-g ghcOpt ...] exprtype <filename> <expression>"+ ,"libhbb-cli apply-to [-q] <function of type string to string> <string>"+ ,""+ ,"<inline-opts> is short for [--adapt-ind|--print-context|--with-color]"+ ,"(there are further modes for testing and development only documented in the sources)"]+ --+ -- Moreover libhbb-cli supports following integration and test modes:+ --+ -- libhbb-cli apply-ttree++data OperationMode = ModeInline InlineOptions+ | ModeSmartInline+ | ModeSmartInlineAdaptInd+ | ModeLocate+ +-- | This function is responsible to parse the optional parameters (called+-- options). If there is a parameter that doesn't match an option this function+-- stops and returns its accumulated result. The extraneous arguments then will+-- be the description of the file and the line.+takeOptions :: ([String],InlineOptions) -> ([String],InlineOptions)+takeOptions (("--print-context":rest),ops) = takeOptions (rest,(ops { showContext = True }))+takeOptions (("--with-color" :rest),ops) = takeOptions (rest,(ops { showAnsiColored = True }))+takeOptions (("--adapt-ind" :rest),ops) = takeOptions (rest,(ops { adaptToTargetEnv = AdaptIndToTargetEnv }))+takeOptions x@(_,_) = x++main :: IO ()+main = do+ programArgs <- getArgs++ -- First we want to filter out the options that GHC needs+ let (ghcOptions,otherArgs) = + let optdescr :: [OptDescr String]+ optdescr = [Option ['g'] [] (ReqArg id "ghc-option") "options passed to ghc"]+ in case O.getOpt RequireOrder optdescr programArgs of+ (_,_,(_:_)) -> error "Wrong usage of ghc-specific options (every -g must be followed by a GHC option)"+ (g,o,[] ) -> (g,o)++ putApplyToResult :: Bool -> (String,Maybe String) -> IO ()+ putApplyToResult False (res,Just wa) = do hPutStr stderr wa + hPutStrLn stderr "> "+ hPutStrLn stderr "> Pass the flag '-q' to suppress this warning!"+ putApplyToResult False (res,Nothing)+ putApplyToResult True (res,Just wa) = hPutStr stderr wa >> putApplyToResult True (res,Nothing)+ putApplyToResult _ (res,Nothing) = putStr res++ case (ghcOptions,otherArgs) of+ -- The following mode is for integration and testing and not documented+ -- by the API:+ (_ ,["apply-ttree"]) -> testModeApplyTTree defaultApplyTTreeArgs >>= putStr+ -- These modes are 'productive' modes:+ (_ ,("occurrences-of":f:l:c:others)) -> occurrencesOf ghcOptions f (BufLoc (read l) (read c)) others >>= putStr . showOccurrencesOfResult+ (_ ,["exprtype",f,expr]) -> exprtype ghcOptions f expr >>= putStrLn . showExprTypeResult+ ([],["apply-to","-q",f,str ]) -> applyTo True f str >>= putApplyToResult True+ ([],["apply-to", f,str ]) -> applyTo False f str >>= putApplyToResult False+ (_ ,("apply-to":_)) -> error "Mode 'applyto' doesn't allow to specify ghc options (with -g)"+ _ -> do+ (opMode,occFile,loc1,maybeLoc2) <- do+ case otherArgs of+ ["locate" ,f,l,c] -> return (ModeLocate ,f,(BufLoc (read l::Int) (read c::Int)),Nothing)+ ("smart-inline":rest) -> + case rest of+ ("--adapt-ind":f:sl:sc:el:ec:[]) -> return (ModeSmartInlineAdaptInd,f,(BufLoc (read sl::Int) (read sc::Int)),+ (Just $ BufLoc (read el::Int) (read ec::Int)))+ ("--adapt-ind":f:sl:sc:[]) -> return (ModeSmartInlineAdaptInd,f,(BufLoc (read sl::Int) (read sc::Int)),Nothing)+ (f:sl:sc:el:ec:[]) -> return (ModeSmartInline,f,(BufLoc (read sl::Int) (read sc::Int)),+ (Just $ BufLoc (read el::Int) (read ec::Int)))+ (f:sl:sc:[]) -> return (ModeSmartInline,f,(BufLoc (read sl::Int) (read sc::Int)),Nothing)+ _ -> do putStrLn "Invalid parameters."+ putStrLn usageStr; exitFailure+ ("inline":rest) -> do+ let (locspec,options) = takeOptions (rest,defaultInlineOptions)+ case locspec of+ (f:sl:sc:el:ec:[]) -> return (ModeInline options,f,(BufLoc (read sl::Int) (read sc::Int)),+ (Just $ BufLoc (read el::Int) (read ec::Int)))+ (f:sl:sc:[]) -> return (ModeInline options,f,(BufLoc (read sl::Int) (read sc::Int)),Nothing)+ _ -> do putStrLn "Invalid parameters."+ putStrLn usageStr; exitFailure+ _ -> do putStrLn usageStr; exitFailure+ case opMode of+ ModeInline options -> inline ghcOptions options occFile loc1 maybeLoc2 >>= putStrLn . showInlineResult+ ModeSmartInline -> smartinline ghcOptions IgnoreIndOfTargetEnv occFile loc1 maybeLoc2 >>= LB.putStr . showSmartInlineResultAsByteString+ ModeSmartInlineAdaptInd -> smartinline ghcOptions AdaptIndToTargetEnv occFile loc1 maybeLoc2 >>= LB.putStr . showSmartInlineResultAsByteString+ ModeLocate -> locate ghcOptions occFile loc1 >>= putStrLn . showLocateResult