{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}

module Language.Haskell.Exference.ExpressionToHaskellSrc
  ( convert
  , convertToFunc
  )
where



import qualified Language.Haskell.Exference.Core.Expression as E
import qualified Language.Haskell.Exference.Core.Types as T
import qualified Language.Haskell.Exference.Core.TypeUtils as TU
import Language.Haskell.Exts.Syntax

import Control.Monad ( forM )

import Control.Applicative

import qualified Data.Map as M
import Data.Map ( Map )

import Data.HList.ContainsType

import Data.Functor.Identity

import Control.Monad.Trans.MultiState



-- TODO:
-- 1) merge nested lambdas

-- qualification level -> internal-expression -> haskell-src-expression
-- level 0 = no qualication
-- level 1 = qualification for anything but infix operators
-- level 2 = full qualification (prevents infix operators)
convert :: Int
        -> E.Expression
        -> Exp
convert q e = runIdentity
            $ runMultiStateTNil
            $ withMultiStateA (M.empty :: Map T.TVarId T.HsType)
            $ do
                E.collectVarTypes e
                h e []
  where
    h (E.ExpLambda i ty e1) is = h e1 ((i, ty):is)
    h rhsExp [] = convertExp q rhsExp
    h rhsExp is = [ Lambda noLoc (map (PVar . Ident) params) cr
                  | cr <- convertExp q rhsExp
                  , params <- mapM (T.showTypedVar . fst)
                                   (reverse is)
                  ]

convertToFunc :: Int
              -> String
              -> E.Expression
              -> Decl
convertToFunc q ident e = runIdentity
                        $ runMultiStateTNil
                        $ withMultiStateA (M.empty :: Map T.TVarId T.HsType)
                        $ do
                            E.collectVarTypes e
                            h e []
  where
    h (E.ExpLambda i ty e1) is = h e1 ((i, ty):is)
    h rhsExp is = [ FunBind [Match noLoc
                                   (Ident ident)
                                   (map (PVar . Ident) params)
                                   Nothing
                                   rhs'
                                   Nothing]
                  | rhs' <- UnGuardedRhs <$> convertExp q rhsExp
                  , params <- mapM (T.showTypedVar . fst) (reverse is)
                  ]

-- qualification level -> internal-expression -> haskell-src-expression
-- level 0 = no qualication
-- level 1 = qualification for anything but infix operators
-- level 2 = full qualification (prevents infix operators)
convertExp :: Int -> E.Expression -> MultiState '[Map T.TVarId T.HsType] Exp
convertExp q = convertInternal q 0

parens :: Bool -> Exp -> Exp
parens True e = Paren e
parens False e = e

-- qualification level -> precedence -> expression
-- level 0 = no qualication
-- level 1 = qualification for anything but infix operators
-- level 2 = full qualification (prevents infix operators)
convertInternal
  :: Int -> Int -> E.Expression -> MultiState '[Map T.TVarId T.HsType] Exp
convertInternal _ _ (E.ExpVar i _) = Var . UnQual . Ident
                                    <$> T.showTypedVar i
convertInternal q _ (E.ExpName qn) =
  return $ Con $ UnQual $ Ident $ convertName q qn
convertInternal q p (E.ExpLambda i _ e) =
  [ parens (p>=1) $ Lambda noLoc [PVar $ Ident $ vname] ce
  | ce <- convertInternal q 0 e
  , vname <- T.showTypedVar i
  ]
convertInternal q p (E.ExpApply e1 pe) = recurseApply e1 [pe]
  where
    defaultApply :: E.Expression -> [E.Expression] -> MultiState '[Map T.TVarId T.HsType] Exp
    defaultApply e pes = do
      f  <- convertInternal q 2 e
      ps <- mapM (convertInternal q 3) pes
      return $ parens (p>=3) $ foldl App f ps
    recurseApply :: E.Expression -> [E.Expression] -> MultiState '[Map T.TVarId T.HsType] Exp
    recurseApply (E.ExpApply e1' pe') pes = recurseApply e1' (pe':pes)
    recurseApply e@(E.ExpName qname) pes = do
      case qname of
        T.TupleCon i
          | i==length pes
          , q<2 ->
            Tuple Boxed <$> mapM (convertInternal q 0) pes
        T.Cons
          | q<2
          , [p1, p2] <- pes -> do
              q1 <- convertInternal q 1 p1
              q2 <- convertInternal q 2 p2
              return $ parens (p>=2) $ InfixApp
                q1
                (QVarOp $ UnQual $ Symbol ":")
                q2            
        T.QualifiedName _ ('(':opR)
          | q<2
          , [p1, p2] <- pes -> do
              q1 <- convertInternal q 1 p1
              q2 <- convertInternal q 2 p2
              return $ parens (p>=2) $ InfixApp
                q1
                (QVarOp $ UnQual $ Symbol $ takeWhile (/=')') opR)
                q2
        _ -> defaultApply e pes
    recurseApply e pes = defaultApply e pes
convertInternal _ _ (E.ExpHole i) = return $ Var
                                           $ UnQual
                                           $ Ident
                                           $ "_"++T.showVar i
convertInternal q p (E.ExpLet i _ bindE inE) = do
  rhs <- convertInternal q 0 bindE
  varName <- T.showTypedVar i
  let convBind = PatBind noLoc
                   (PVar $ Ident $ varName)
                   (UnGuardedRhs $ rhs)
                   Nothing
  e <- convertInternal q 0 inE
  return $ parens (p>=2) $ mergeLet convBind e
convertInternal q p (E.ExpLetMatch n ids bindE inE) = do
  rhs <- convertInternal q 0 bindE
  let name = convertName q n
  varNames <- mapM (T.showTypedVar . fst) ids
  let convBind = PatBind noLoc
                   (PParen $ PApp (UnQual $ Ident $ name)
                                  (map (PVar . Ident) varNames))
                   (UnGuardedRhs $ rhs)
                   Nothing
  e <- convertInternal q 0 inE
  return $ parens (p>=2) $ mergeLet convBind e
convertInternal q p (E.ExpCaseMatch bindE alts) = do
  e <- convertInternal q 0 bindE
  as <- alts `forM` \(c, vars, expr) -> do
    rhs <- convertInternal q 0 expr
    let name = convertName q c
    varNames <- mapM (T.showTypedVar . fst) vars
    return $ Alt noLoc
        (PApp (UnQual $ Ident $ name)
              (map (PVar . Ident) varNames))
        (UnGuardedRhs $ rhs)
        Nothing
  return $ parens (p>=2) $ Case e as

convertName :: Int -> T.QualifiedName -> String
convertName d qn = case (d, qn) of
  (0, T.QualifiedName _ n) -> n
  (_, n)                   -> show n

mergeLet :: Decl -> Exp -> Exp
mergeLet convBind (Let (BDecls otherBinds) finalIn)
  = Let (BDecls $ convBind:otherBinds) finalIn
mergeLet convBind finalIn                 
  = Let (BDecls [convBind]) finalIn

noLoc :: SrcLoc
noLoc = SrcLoc "" 0 0