diff --git a/Language/Haskell/HBB/Inline.hs b/Language/Haskell/HBB/Inline.hs --- a/Language/Haskell/HBB/Inline.hs +++ b/Language/Haskell/HBB/Inline.hs @@ -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)] diff --git a/Language/Haskell/HBB/Internal/GHCHighlevel.hs b/Language/Haskell/HBB/Internal/GHCHighlevel.hs --- a/Language/Haskell/HBB/Internal/GHCHighlevel.hs +++ b/Language/Haskell/HBB/Internal/GHCHighlevel.hs @@ -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 diff --git a/Language/Haskell/HBB/Internal/InterfaceTypes.hs b/Language/Haskell/HBB/Internal/InterfaceTypes.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/HBB/Internal/InterfaceTypes.hs @@ -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. diff --git a/Language/Haskell/HBB/Internal/InternalTTree.hs b/Language/Haskell/HBB/Internal/InternalTTree.hs --- a/Language/Haskell/HBB/Internal/InternalTTree.hs +++ b/Language/Haskell/HBB/Internal/InternalTTree.hs @@ -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_elemOffset + 1 - -- Non-First NewSection within parent: - -- + 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 diff --git a/Language/Haskell/HBB/Internal/InternalTTreeCreation.hs b/Language/Haskell/HBB/Internal/InternalTTreeCreation.hs --- a/Language/Haskell/HBB/Internal/InternalTTreeCreation.hs +++ b/Language/Haskell/HBB/Internal/InternalTTreeCreation.hs @@ -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 -- (space separated). When converting to a lambda -- function the pattern must have the form (,) @@ -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 -> diff --git a/Language/Haskell/HBB/Internal/SrcSpan.hs b/Language/Haskell/HBB/Internal/SrcSpan.hs --- a/Language/Haskell/HBB/Internal/SrcSpan.hs +++ b/Language/Haskell/HBB/Internal/SrcSpan.hs @@ -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)) diff --git a/Language/Haskell/HBB/Locate.hs b/Language/Haskell/HBB/Locate.hs --- a/Language/Haskell/HBB/Locate.hs +++ b/Language/Haskell/HBB/Locate.hs @@ -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) diff --git a/Language/Haskell/HBB/OccurrencesOf.hs b/Language/Haskell/HBB/OccurrencesOf.hs --- a/Language/Haskell/HBB/OccurrencesOf.hs +++ b/Language/Haskell/HBB/OccurrencesOf.hs @@ -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 diff --git a/Language/Haskell/HBB/SmartInline.hs b/Language/Haskell/HBB/SmartInline.hs --- a/Language/Haskell/HBB/SmartInline.hs +++ b/Language/Haskell/HBB/SmartInline.hs @@ -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) diff --git a/Language/Haskell/HBB/TestModes/ApplyTTree.hs b/Language/Haskell/HBB/TestModes/ApplyTTree.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/HBB/TestModes/ApplyTTree.hs @@ -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 diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -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. diff --git a/editor-plugin/vim/hbb.vim b/editor-plugin/vim/hbb.vim deleted file mode 100644 --- a/editor-plugin/vim/hbb.vim +++ /dev/null @@ -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() -":vmap I :call HBBInlineSelection( "with saving" ) diff --git a/libhbb.cabal b/libhbb.cabal --- a/libhbb.cabal +++ b/libhbb.cabal @@ -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 diff --git a/src/HBBSimpleCLI.hs b/src/HBBSimpleCLI.hs deleted file mode 100644 --- a/src/HBBSimpleCLI.hs +++ /dev/null @@ -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 " - ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] inline [--print-context|--with-color] [ ]" - ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] smart-inline [ ]" - ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] occurrences-of [ ...]" - ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] exprtype " - ,"hbb-simple-cli apply-to [-q] "] - -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) diff --git a/src/LibHbbCli.hs b/src/LibHbbCli.hs new file mode 100644 --- /dev/null +++ b/src/LibHbbCli.hs @@ -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 " + ,"libhbb-cli [-g ghcOpt ...] inline [ ]" + ,"libhbb-cli [-g ghcOpt ...] smart-inline [--adapt-ind] [ ]" + ,"libhbb-cli [-g ghcOpt ...] occurrences-of [ ...]" + ,"libhbb-cli [-g ghcOpt ...] exprtype " + ,"libhbb-cli apply-to [-q] " + ,"" + ," 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