{-# 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 instance ConvertibleToTTree (LambdaNotationStyle,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 (notationStyle,L _ (GRHS stmts expr@(L (RealSrcSpan _) _)),mbValBinds) = do lambdaStyle <- ask exprsTTree <- local (const ProduceEqual) (toTTree expr) case (notationStyle,stmts,lambdaStyle) of (Val2InlShort ,[],ProduceLambda) -> return exprsTTree --(Val2InlWithCase,[],ProduceLambda) -> 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 (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 -- 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 (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 (notationStyle,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. 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). - - 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 = 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 -- 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 "(,,)" or "()". 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 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 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 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 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 (_,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 " 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)"