{-# 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 <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 "(,,)" 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)"