diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,13 @@ +Version 0.4.1.0 +--------------- + - Adding support for inlining value bindings with guards or *where* + expressions. If such a value bindings is encountered, a trivial *case* + expression is added `case () of () | ..."`. + - Fixing a bug that prevented functions with one match and a single parameter + to be inlined correctly. In this case a prefix like `\a case a of` has been + produced, which is invalid as `->` is missing. + Version 0.4.0.2 --------------- 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 @@ -53,9 +53,8 @@ endS2 = srcLocLine $ realSrcSpanEnd s2 in endS1 < startS2 || endS2 < startS1 -type IsValueBinding = Bool -instance ConvertibleToTTree (IsValueBinding,LGRHS Name,Maybe (HsValBindsLR Name Name)) where +instance ConvertibleToTTree (LambdaNotationStyle,LGRHS Name,Maybe (HsValBindsLR Name Name)) where -- [Indentation] -- @@ -96,15 +95,12 @@ -- x -> x * fact (x-1))) 5 -- - toTTree (isValueBinding,L _ (GRHS stmts expr@(L (RealSrcSpan _) _)),mbValBinds) = do + toTTree (notationStyle,L _ (GRHS stmts expr@(L (RealSrcSpan _) _)),mbValBinds) = do lambdaStyle <- ask exprsTTree <- local (const ProduceEqual) (toTTree expr) - case (isValueBinding,stmts,lambdaStyle) of - (True ,(_:_),ProduceLambda) -> error $ "There is no support for inlining value bindings with guards (e.g. 'someVal | isOk = 3.14159')!" - (True ,[] ,ProduceLambda) -> - {- Ok, this is a value binding. Value bindings are simply - - represented by their value. -} - return exprsTTree + case (notationStyle,stmts,lambdaStyle) of + (Val2InlShort ,[],ProduceLambda) -> return exprsTTree + --(Val2InlWithCase,[],ProduceLambda) -> return exprsTTree (_ ,[] ,_ ) -> do -- A GRHS without guards. let addition = case lambdaStyle of ProduceLambda -> ["-> "] @@ -189,12 +185,10 @@ toTTree (HsIPBinds _) = error "What is IP-Binds?" toTTree (HsValBinds vb) = toTTree vb -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 } - ,notationStyle) = do +instance ConvertibleToTTree (GRHSs Name,LambdaNotationStyle) where + toTTree (GRHSs { grhssGRHSs = [] },_) = error "internal error (expected at least one grhs)" + toTTree (GRHSs { grhssGRHSs = content + , grhssLocalBinds = whereCl },notationStyle) = do whatToProduce <- ask @@ -202,18 +196,18 @@ -- 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 + (_ ,ProduceEqual ,HsValBinds _) -> Nothing + (FunShortNotation,ProduceLambda,HsValBinds vb) -> Just vb + (FunLongNotation ,ProduceLambda,HsValBinds _) -> Nothing + (_ ,_ ,HsIPBinds _) -> error "Internal error (what is IPBinds)?" + _ -> 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,whereClAsLet) + tr <- toTTree (notationStyle,grhs,whereClAsLet) let insPos = NewSection pos return $ ((pos+1,tot),(insPos,tr):acc) (_,res) <- foldM arg ((1,length content),[]) content @@ -246,30 +240,40 @@ {- - [Value bindings] - - - Value bindings should be supported by HBB insofar as they do not contain - - guards (have a look at the documentation). This means that HBB should be + - Value bindings should be supported by HBB. This means that HBB should be - able to inline following names: - - somevar = 12 - - - fact = (\a -> case a of 1 -> 1 - - x -> x * fact (x-1) + - fact = \a -> case a of 1 -> 1 + - x -> x * fact (x-1) - - In GHC value bindings are - as function bindings - represented by the type - 'HsBindLR Name Name'. The difference is that value bindings by nature must - only have one match and the length of the pattern list is zero (no value to - match against). - - - For reasons described in the documentation value bindings with guards (which - - are possible) are not supported by HBB (inlining 'mysine' of the following - - example will raise an exception): + - Value bindings can have guards as the following example shows: - - mysine | useLookUpTable = \r -> lookUpSine r {- custom sine implementation -} - | otherwise = sin {- sine from prelude -} + - + - This value bindings should be converted to: + - + - (case () of () | useLookUpTable -> \r lookUpSine r + - | otherwise -> sin) -} -data LambdaNotationStyle = ShortNotationStyle -- ^ may convert a where-expression to a let-expression - | LongNotationWithWhere +data LambdaNotationStyle = FunShortNotation -- ^ may convert a where-expression to a let-expression + | FunLongNotation + -- | Value bindings with guards or where expressions + -- are replaced by a case expression + -- "case () of () |..." which reflects these guards + | Val2InlWithCase + -- | Value bindings without guards and where + -- expression are replaced by their left hand side + -- surrounded by brackets. + | Val2InlShort instance ConvertibleToTTree ([LPat Name],(GRHSs Name),LambdaNotationStyle) where toTTree (patterns,grhss,notationStyle) = do @@ -293,8 +297,9 @@ -- We have to use a folde operation to create the individual -- childs of our top-level addition. The top-level addition is - -- something like "(,,)". The insertion position whithin this - -- top-level addition is accumulated during folding. + -- something like "(,,)" or "()". The insertion position + -- whithin this top-level addition is accumulated during + -- folding. let (_,childs) = let foldArg :: (Int,[(InsertionInfo,InternalTTree)]) -> RealSrcSpan @@ -302,28 +307,22 @@ foldArg (curOffs,acc) curSpn = let curTree = TTree (Display curSpn) [] in (curOffs+1,(IncInline $ pointBufSpan 1 curOffs,curTree):acc) - in case (length patterns,notationStyle) of - -- Have a look at the comment [Bindings - -- with zero matches] for examples of - -- zero-parameter bindings that should - -- be supported. - (0,_) -> (0,[]) - (1,_) -> foldl foldArg (1 ,[]) patternspans - (_,LongNotationWithWhere) -> foldl foldArg (2 {- 2 means after "(" -},[]) patternspans - (_,ShortNotationStyle) -> foldl foldArg (1 ,[]) patternspans - topLvlAddition = case (length patterns,notationStyle) of - (0,_) -> "" -- a value binding - (1,_) -> "" - (_,LongNotationWithWhere) -> "(" ++ (replicate ((length patterns) - 1) ',') ++ ")" - (_,ShortNotationStyle) -> (replicate ((length patterns) - 1) ' ') + in case notationStyle of + (FunLongNotation ) -> foldl foldArg (2 {- 2 means after "(" -},[]) patternspans + (FunShortNotation) -> foldl foldArg (1 ,[]) patternspans + _ -> (0,[]) + topLvlAddition = case notationStyle of + (Val2InlShort) -> "" -- a value binding without guard and "where" doesn't need a prefix + (FunShortNotation) -> (replicate ((length patterns) - 1) ' ') + _ -> "(" ++ (replicate ((length patterns) - 1) ',') ++ ")" in TTree (Addition [topLvlAddition]) childs - let isValueBinding = (length patterns) == 0 - grhssTree <- toTTree (isValueBinding,grhss,notationStyle) - return $ case isValueBinding of - False -> TTree (Addition [" "]) [(IncInline $ pointBufSpan 1 1,stmtsTree) - ,(IncInline $ pointBufSpan 1 2,grhssTree)] - True -> grhssTree + grhssTree <- toTTree (grhss,notationStyle) + return $ case notationStyle of + Val2InlShort -> TTree (Addition [""]) [(IncInline $ pointBufSpan 1 1,grhssTree)] + _ -> TTree (Addition [" "]) [(IncInline $ pointBufSpan 1 1,stmtsTree) + ,(IncInline $ pointBufSpan 1 2,grhssTree)] + instance ConvertibleToTTree (LHsBindLR Name Name) where toTTree (L _ (FunBind { fun_id = (L (RealSrcSpan nameSpan) _) , fun_matches = (MatchGroup matches@(firstMatch:_) _) })) = do @@ -355,18 +354,29 @@ isGuardedGRHS (L _ (GRHS [] _)) = False isGuardedGRHS _ = True - notationStyle = case (whatToProduce,any isGuarded matches,length matches) of - (ProduceLambda,False,1) -> ShortNotationStyle - _ -> LongNotationWithWhere + hasGRHSWithCase :: LMatch Name -> Bool + hasGRHSWithCase (L _ (Match _ _ (GRHSs { grhssLocalBinds = EmptyLocalBinds }))) = False + hasGRHSWithCase _ = True + notationStyle = case (whatToProduce,any isGuarded matches,length matches,nrOfParameters) of + (ProduceLambda,isGrdd,1,0) -> case (isGrdd,hasGRHSWithCase firstMatch) of + (False,False) -> Val2InlShort + _ -> Val2InlWithCase + (ProduceLambda,False,1,_) -> FunShortNotation + _ -> FunLongNotation + + -- The "prefix" is the part before the single matches. + -- For ordinary functions this is either "\(a,b) -> case (a,b) of " + -- or "\a b ->" + -- For value bindings this is either "" + -- or "case () of " 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,_ ) -> "" -- 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 " + (_,Val2InlShort ) -> "" + (_,Val2InlWithCase ) -> "case () of " -- "() | guard1 ->" + -- " | guard2 ->" + (_,FunShortNotation) -> "\\" -- This is a function without guards and only a single match which + -- can be written shorter... + (1,FunLongNotation ) -> "\\a -> case a of " _ -> let caseParameters = take nrOfParameters ['a'..] in "\\" ++ (intersperse ' ' caseParameters) ++ " -> case (" ++ (intersperse ',' caseParameters) ++ ") of " 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.4.0.2 +version: 0.4.1.0 -- A short (one-line) description of the package. synopsis: Backend for text editors to provide better Haskell editing support.