libhbb-0.4.0.2: Language/Haskell/HBB/Internal/InternalTTreeCreation.hs
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS -Wall #-}
module Language.Haskell.HBB.Internal.InternalTTreeCreation where
import Language.Haskell.HBB.Internal.InternalTTree
import Language.Haskell.HBB.Internal.SrcSpan
import Language.Haskell.HBB.Internal.TTree
import Control.Monad.Reader
import Data.List (sortBy,intersperse)
import SrcLoc
import Name
import GHC
import Bag
-- 'ConversionInfo' is the type the reader monad in ConvertibleToTTree is
-- parametrized with. It indicates whether the current element should be
-- transformed so that it forms a lambda context or not. As the source code is
-- recursive and self-containing the type 'HsBindLR Name Name' which usually
-- represents a function binding may occure several times. But of course the
-- (lower-level) function bindings should not be written in lambda style but
-- only the top one. ConversionInfo makes this distinction...
data ConversionInfo = ProduceLambda
| ProduceEqual
-- This is the central type class of which instances can be converted to a
-- TTree that represents a lambda function. Potential instances of this class
-- are elements that are below the (GHC) type (HsBindsLR Name Name) which
-- represents a function binding.
class ConvertibleToTTree a where
toTTree :: a -> Reader ConversionInfo InternalTTree
-- [LStmt Name] is for example the guard in a GRHS.
-- We use a single display for the guard by joining the src-spans.
instance ConvertibleToTTree [LStmt Name] where
toTTree [] = return $ TTree (Addition [""]) []
toTTree stmts = do
let stmtsLoc :: [RealSrcSpan]
stmtsLoc = [ r | (L (RealSrcSpan r) _) <- stmts ]
wholeStmtsLoc = foldl1 combineRealSrcSpans stmtsLoc
return $ TTree (Display wholeStmtsLoc) []
instance ConvertibleToTTree (LHsExpr Name) where
toTTree (L (RealSrcSpan rspn) _) = return $ TTree (Display rspn) []
toTTree _ = error "internal error (unexpected unhelpful src-span)"
-- Helper function to determine whether to RealSrcSpans
-- affect areas which are on separate lines...
onDifferentLines :: RealSrcSpan -> RealSrcSpan -> Bool
onDifferentLines s1 s2 =
let startS1 = srcLocLine $ realSrcSpanStart s1
endS1 = srcLocLine $ realSrcSpanEnd s1
startS2 = srcLocLine $ realSrcSpanStart s2
endS2 = srcLocLine $ realSrcSpanEnd s2
in endS1 < startS2 || endS2 < startS1
type IsValueBinding = Bool
instance ConvertibleToTTree (IsValueBinding,LGRHS Name,Maybe (HsValBindsLR Name Name)) where
-- [Indentation]
--
-- There is one case that must be discussed. If the code for 'expr' does
-- start on a new line we have to make an exception. Example:
--
-- (l,x) | x /= 10 && l /= "" -> l ++ (show x) ++ "th world!"
-- | otherwise ->
-- l ++ (show x) ++ "th world, you are the winner!"
--
-- By simply using our join algorithms the result would be:
--
-- (l,x) | x /= 10 && l /= "" -> l ++ (show x) ++ "th world!"
-- | otherwise -> l ++ (show x) ++ "th world, you are the winner!"
--
-- So we have to explicitely check whether the last line of the statements
-- is on the same line as the first expression. If this is not the case we
-- have to add a newline and increment indentation.
--
-- [No patterns but a guard]
--
-- There are some cornercases that should be considered. The following
-- example shows a binding with no patterns but one guard:
--
-- shouldTrace = False
--
-- fact | trace "calling 'fact'" False = undefined
-- fact = (\a -> case a of 1 -> 1
-- x -> x * fact (x-1))
--
-- If there are no matches then the function should be inlined with an
-- alternatvie leading statement:
--
-- main = IO Int
-- main = return $ fact 5
--
-- main = return $ (case isOk of True -> (\a -> case a of 1 -> 1
-- x -> x * fact (x-1))) 5
--
toTTree (isValueBinding,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
(_ ,[] ,_ ) -> do
-- 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 addition = case lambdaStyle of ProduceLambda -> ["| -> "]
ProduceEqual -> ["| = " ]
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 =
case combineSrcSpans (RealSrcSpan s1) (RealSrcSpan s2) of
(RealSrcSpan r) -> r
_ -> error "expected real src-span from combineSrcSpans"
-- HsValBindsLR is a possible element of HsLocalBindsLR which is used for the
-- where-clause...
instance ConvertibleToTTree (HsValBindsLR Name Name) where
toTTree (ValBindsIn _ _) = error "internal error (expected dependency analyzed where-clause)"
toTTree (ValBindsOut binds _) =
let -- [The Bag data structure]
--
-- GHC stores bindings in a Bag probably because all statements
-- are mutually recursive (and therefore a list which has an order
-- is inadequate).
--
-- [Avoid converting the local function bindings to lambdas as well]
--
-- Each of these bindings may contain function bindings (again). We
-- would make the functions within these bindings lambda function
-- as well if we would call 'toTTreeDep'. Furtunately we can copy only
-- the text of them by looking at their src-spans. This is what is
-- done in 'toTTreeDep' for (LHsBindLR Name)...
allBags :: [Bag (LHsBindLR Name Name)]
allBags = map (\(_,lHsBind) -> lHsBind) binds
-- Ok, now we have the single bindings in Bag which is a GHC
-- structure with no order. We need them in the order they appear
-- in the source file so we convert them to a list and sort them.
-- Additionally the content is not needed any more (we use the span
-- to form our tree (with displays as childs)...
asList :: [RealSrcSpan]
asList = sortBy
compareByStartLoc
[ r | (L (RealSrcSpan r) _) <- concatMap bagToList allBags]
asSingleSpan :: RealSrcSpan
asSingleSpan = foldl1 combineRealSrcSpans asList
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?"
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
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,whereClAsLet)
let insPos = NewSection pos
return $ ((pos+1,tot),(insPos,tr):acc)
(_,res) <- foldM arg ((1,length content),[]) content
return res
let grhssAsTree :: InternalTTree
grhssAsTree = TTree (Addition [""]) grhssAsNewSections
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]
-
- 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
- able to inline following names:
-
- somevar = 12
-
- 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):
-
- mysine | useLookUpTable = \r -> lookUpSine r {- custom sine implementation -}
- | otherwise = sin {- sine from prelude -}
-}
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>)
-- (it must be a tuple to match against).
--
-- At this point we must support both styles because function bindings
-- local to our (newly created) lambda function should not be changed.
whatToProduce <- ask
let patternspans :: [RealSrcSpan]
patternspans = [ r | (L (RealSrcSpan r) _) <- patterns ]
stmtsTree = case whatToProduce of
ProduceEqual -> TTree (Display $ foldl1 combineRealSrcSpans patternspans) []
ProduceLambda ->
-- 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.
let (_,childs) = let foldArg
:: (Int,[(InsertionInfo,InternalTTree)])
-> RealSrcSpan
-> (Int,[(InsertionInfo,InternalTTree)])
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 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
instance ConvertibleToTTree (LHsBindLR Name Name) where
toTTree (L _ (FunBind { fun_id = (L (RealSrcSpan nameSpan) _)
, fun_matches = (MatchGroup matches@(firstMatch:_) _) })) = do
whatToProduce <- ask
let nrOfParameters =
let (L _ (Match pttrns _ _)) = firstMatch
in length pttrns
-- Prefix example: "\a b c -> case (a,b,c) of" with content: "(x,y,z) | guards ->"
-- 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,_ ) -> "" -- 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 "
matches2lambda
:: ((Int,Int),[(InsertionInfo,InternalTTree)])
-> (LMatch Name)
-> Reader ConversionInfo ((Int,Int),[(InsertionInfo,InternalTTree)])
matches2lambda ((nr,tot),acc) (L _ (Match patterns _ grhss)) = do
innerTree <- toTTree (patterns,grhss,notationStyle)
return $ case whatToProduce of
ProduceEqual ->
((nr+1,tot),((
(NewSection nr)
,TTree
(Addition [" "])
[(IncInline (pointBufSpan 1 1),TTree (Display nameSpan) [])
,(IncInline (pointBufSpan 1 2),innerTree)]
):acc))
ProduceLambda ->
((nr+1,tot),((NewSection nr,innerTree):acc))
(_,allChilds) <- foldM matches2lambda ((1,length matches),[]) matches
case whatToProduce of
ProduceLambda ->
return $ TTree
(Addition ["()"])
[(IncInline $ pointBufSpan 1 2,TTree (Addition [prefix]) allChilds)]
ProduceEqual -> return $ TTree (Addition [""]) allChilds
toTTree (L _ (FunBind {})) = error "internal error (unexpected function binding structure)"
toTTree (L l (PatBind {})) = do
-- A pattern bindings can have several forms:
--
-- let x :: Int = ...
-- let tup :: (Int,Int) = ...
-- let f :: Int -> Int = ...
-- let ['a'] = ...
--
-- But not:
--
-- let x =
-- let f =
--
-- These forms parse as FunBind.
whatToProduce <- ask
case (whatToProduce,l) of
(ProduceLambda,_ ) -> error $ "The name referred to is bound by a so-called \"pattern binding\" " ++
"for which inlining is not supported."
(ProduceEqual ,RealSrcSpan r) -> return $ TTree (Display r) []
(ProduceEqual ,_ ) -> error $ "internal error (Unexpected unhelpful src-span in PatBind)"
toTTree (L _ (VarBind {})) = error "internal error (unexpected VarBind: ghc docs say VarBinds are produced by the typechecker)"
toTTree (L _ (AbsBinds {})) = error "internal error (unexpected AbsBinds: ghc docs say AbsBinds are produced by the typechecker)"