libhbb 0.4.0.2 → 0.4.1.0

raw patch · 3 files changed

+82/−63 lines, 3 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• Language/Haskell/HBB/Internal/InternalTTreeCreation.hs +72/−62
• libhbb.cabal +1/−1

@@ -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 --------------- 

@@ -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 "

@@ -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.