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
data ConversionInfo = ProduceLambda
| ProduceEqual
class ConvertibleToTTree a where
toTTree :: a -> Reader ConversionInfo InternalTTree
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)"
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
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
(_ ,[] ,_ ) -> do
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
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"
instance ConvertibleToTTree (HsValBindsLR Name Name) where
toTTree (ValBindsIn _ _) = error "internal error (expected dependency analyzed where-clause)"
toTTree (ValBindsOut binds _) =
let
allBags :: [Bag (LHsBindLR Name Name)]
allBags = map (\(_,lHsBind) -> lHsBind) binds
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?"
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
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
(HsValBinds vb,Nothing) -> do
whereTree <- toTTree vb
return $ TTree (Addition [""]) [(NewSection 1,grhssAsTree)
,(NewSection 2,TTree (Addition ["where"
," "]) [(NewSection 1,whereTree)])]
(HsValBinds _,Just _) -> do
return $ grhssAsTree
data LambdaNotationStyle = FunShortNotation
| FunLongNotation
| Val2InlWithCase
| Val2InlShort
instance ConvertibleToTTree ([LPat Name],(GRHSs Name),LambdaNotationStyle) where
toTTree (patterns,grhss,notationStyle) = do
whatToProduce <- ask
let patternspans :: [RealSrcSpan]
patternspans = [ r | (L (RealSrcSpan r) _) <- patterns ]
stmtsTree = case whatToProduce of
ProduceEqual -> TTree (Display $ foldl1 combineRealSrcSpans patternspans) []
ProduceLambda ->
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 ,[]) patternspans
(FunShortNotation) -> foldl foldArg (1 ,[]) patternspans
_ -> (0,[])
topLvlAddition = case notationStyle of
(Val2InlShort) -> ""
(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
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
prefix = case (nrOfParameters,notationStyle) of
(_,Val2InlShort ) -> ""
(_,Val2InlWithCase ) -> "case () of "
(_,FunShortNotation) -> "\\"
(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
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)"