{-# 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 -- (space separated). When converting to a lambda -- function the pattern must have the form (,) -- (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)"