libhbb-0.1.1.0: 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,GRHS 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,GRHS stmts expr@(L (RealSrcSpan exprLoc) _)) = 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
let (addition,exprInsPos) = case lambdaStyle of
ProduceLambda -> (["-> "],pointBufSpan 1 4)
ProduceEqual -> (["= "] ,pointBufSpan 1 3)
return $ TTree (Addition addition) [(IncInline exprInsPos,exprsTTree)]
(_ ,_ ,_ ) -> do
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)"
instance ConvertibleToTTree (IsValueBinding,LGRHS Name) where
toTTree (isValueBinding,L _ g) = toTTree (isValueBinding,g)
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
instance ConvertibleToTTree (HsLocalBinds Name) where
toTTree EmptyLocalBinds = return $ TTree (Addition [""]) []
toTTree (HsIPBinds _) = error "What is IP-Binds?" -- TODO is this case relevant?
toTTree (HsValBinds vb) = toTTree vb
instance ConvertibleToTTree (IsValueBinding,GRHSs Name) where
toTTree (_,GRHSs { grhssGRHSs = [] }) = error "internal error (expected at least one grhs)"
toTTree (isValueBinding
,GRHSs { grhssGRHSs = content
, grhssLocalBinds = whereCl } ) = do
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)
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 of
HsIPBinds _ -> error "what is HsIPBinds?"
EmptyLocalBinds -> return $ grhssAsTree
HsValBinds vb -> do
whereTree <- toTTree vb
return $ TTree (Addition [""]) [(NewSection 1,grhssAsTree)
,(NewSection 2,TTree (Addition ["where"
," "]) [(NewSection 1,whereTree)])]
{-
- [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 -}
-}
instance ConvertibleToTTree ([LPat Name],(GRHSs Name)) where
toTTree (patterns,grhss) = 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 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
_ -> foldl foldArg (2 {- 2 means after "(" -},[]) patternspans
topLvlAddition = case length patterns of
0 -> ""
1 -> ""
_ -> "(" ++ (replicate ((length patterns) - 1) ',') ++ ")"
in TTree (Addition [topLvlAddition]) childs
let isValueBinding = (length patterns) == 0
grhssTree <- toTTree (isValueBinding,grhss)
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
prefix = case nrOfParameters 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 "
_ -> 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)
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)"