{-# 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,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 (isValueBinding,L _ (GRHS stmts expr@(L (RealSrcSpan _) _)),mbValBinds) = 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
                -- 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 (IsValueBinding,GRHSs Name,LambdaNotationStyle) where
    toTTree (_,GRHSs { grhssGRHSs      = [] },_) = error "internal error (expected at least one grhs)"
    toTTree (isValueBinding
              ,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
                (ShortNotationStyle   ,ProduceLambda,HsValBinds   vb) -> Just vb
                (LongNotationWithWhere,ProduceLambda,HsValBinds    _) -> Nothing
                (_                    ,_            ,HsIPBinds     _) -> error "Internal error (what is IPBinds)?"
                (_                    ,_            ,EmptyLocalBinds) -> 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 (isValueBinding,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 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 -}
 -}

data LambdaNotationStyle = ShortNotationStyle    -- ^ may convert a where-expression to a let-expression
                         | LongNotationWithWhere

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 "(,,)".  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,notationStyle)
        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" 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

            notationStyle = case (whatToProduce,any isGuarded matches,length matches) of
                (ProduceLambda,False,1) -> ShortNotationStyle
                _                       -> LongNotationWithWhere

            prefix = case (nrOfParameters,notationStyle) of
                -- Have a look at the comment [Bindings with zero matches] for
                -- examples of zero-parameter bindings that should be
                -- supported.
                (0,_                    ) -> ""   -- This is a value binding...
                (_,ShortNotationStyle   ) -> "\\" -- This is a function without guards and only a single match which
                                                  -- can be written shorter...
                (1,LongNotationWithWhere) -> "\\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)"