{-# OPTIONS_GHC -XTemplateHaskell #-}
module Syntax.Expressions
(

    TExp(..), Lit(..),
    tVarE, tWildE, tConE, tAppE, tInfixE, tListE, tTupE, foldTAppE, unfoldTAppE,
    isHOApp, isNilList, isWild,
--    toPat,
--    fromTExp,

    -- checkMatch,
    )
    where

--import Language.Haskell.TH (Exp(..),Lit(..))

import Syntax.Class.Term
import Syntax.Class.Subst
import Syntax.Type
import Syntax.Name
--import Syntax.Ppr

import Data.Function (on)
import Data.List (union, transpose)
import Data.Maybe (catMaybes)
import qualified Data.Map as M
import qualified Data.Traversable as T
import qualified Data.Set as S
import Control.Monad
import Control.Monad.Trans
import Control.Monad.State (get, runStateT, put)

import Data.Maybe (fromMaybe)


data Lit = Char Char
         | String String
         | Int Integer
         | Frac Rational    
    deriving(Eq, Ord, Show)
         
data TExp 
    = TVarE Name Type
    | TConE Name Type           -- contrary to Haskell standard, we use TConE also for function names
    | TLitE Lit Type
    | TAppE TExp TExp
--    | TCondE TExp TExp TExp Type
    | TWildE Name Type          -- an _existentiall_ quantified variable !!! introduced during amtching
--     | LamE [Pat] Exp Type
--     | LetE [Dec] Exp
--     | CaseE Exp [Match]
--     | DoE [Stmt]
--     | CompE [Stmt]
--     | ArithSeqE Range
--     | SigE Exp Type
--     | RecConE Name [FieldExp]
--     | RecUpdE Exp [FieldExp]
    deriving(Ord, Show) -- TODO Eq should consider type equivalences

--------------------------------------------------------------------------------
-- Instance Declarations
--------------------------------------------------------------------------------

instance Eq TExp where
    (==) = equal 

instance Typed TExp where
    typeOf (TVarE _ t)       = t
    typeOf (TConE _ t)       = t
    typeOf (TLitE _ t)       = t
    typeOf (TAppE f _)       = sectionType . typeOf $ f
--    typeOf (TCondE _ _ _  t) = t
    typeOf (TWildE _ t)      = t
    
instance Size TExp where
    sizeS (TVarE _ _)       = (+1)
    sizeS (TConE _ _)       = (+1)
    sizeS (TLitE _ _)       = (+1)
    sizeS (TWildE _ _)      = (+1)
    sizeS (TAppE a1 a2)     = sizeS a1 . sizeS a2
--    sizeS (TCondE c t e _)  = sizeS c . sizeS t . sizeS e



instance Term TExp where
    sameSymAtRoot (TVarE _ _ ) (TVarE _ _)              = True
    sameSymAtRoot (TWildE _ _ ) (TWildE _ _)            = True
    sameSymAtRoot (TConE n1 _) (TConE n2 _)             = n1 == n2
    sameSymAtRoot (TLitE l1 _) (TLitE l2 _)             = l1 == l2
    sameSymAtRoot t1@(TAppE f1 _) t2@(TAppE f2 _)       = sameSymAtRoot f1 f2
    sameSymAtRoot  _ _                                  = False
            
    root e@(TVarE _ _)                      = const e
    root e@(TWildE _ _)                     = const e
    root e@(TConE _ _)                      = const e
    root e@(TLitE _ _)                      = const e
    root e@(TAppE _ _)                      = foldTAppE . head $ unfoldTAppE e

    subterms (TVarE _ _)                        = []
    subterms (TWildE _ _)                       = []
    subterms (TConE _ _)                        = []
    subterms (TLitE _ _)                        = []
    subterms t@(TAppE _ _)                      = unfoldTAppEargs t
--    subterms (TCondE e1 e2 e3 _)                = [e1, e2, e3]

    equal (TVarE s1 t1)  (TVarE s2 t2)  = s1 == s2 && equal t1 t2
    equal s@(TWildE _ _) t              = sameTy s t
    equal s              t@(TWildE _ _) = sameTy s t
    equal (TAppE r1 l1)  (TAppE r2 l2)  = equal r1 r2 && equal l1 l2
    equal (TConE n1 t1)  (TConE n2 t2)  = n1 == n2 && equal t1 t2
    equal (TLitE l1 t1)  (TLitE l2 t2)  = l1 == l2 && equal t1 t2
    equal _              _              = False

    getVar (TVarE n _) = Just n
    getVar _           = Nothing

    toVar t n = TVarE n (typeOf t)


instance Substitutable TExp where
    -- | Straight forward walking down TExp-terms, pass the function call to
    --   subterms and replace variables as specified by the Unifier.
    apply u v@(TVarE n _) = fromMaybe v (lookupS n u)
    apply u     t         = root t $ applyL u (subterms t)
   

----------------------
-- General
----------------------


-- | Returns only the arguments of an 'AppE'xpression.
unfoldTAppEargs = tail . unfoldTAppE

-- | Peals the @Exp@s out of a @AppE@, where the first element should be the 
--   @ConE@ of the function name or the constructor.
unfoldTAppE :: TExp -> [TExp]
unfoldTAppE e = f [] e
    where 
    f done e =
        case e of
            (TAppE e1@(TVarE _ _) e2) -> e1:e2:done
            (TAppE e1@(TConE _ _) e2) -> e1:e2:done
            (TAppE e1 e2)             -> f (e2:done) e1
            _owise                    -> e:done

isFunApp :: TExp -> Bool
isFunApp = hasFunT . head . unfoldTAppE

isHOApp :: TExp -> Bool
isHOApp = hasHOT . head . unfoldTAppE    

isNilList (TConE n _)   = isNil n
isNilList (a@(TAppE _ _)) = isNilList .  head . unfoldTAppE $ a
-- shouldnn't be possible, but doesn't harm either
isNilList _ = False 

isWild :: TExp -> Bool
isWild TWildE {} = True
isWild _         = False

-- the first argument must have a function type
foldTAppE :: TExp -> [TExp] -> TExp
foldTAppE e [] = e 
foldTAppE et (e:es) = foldTAppE (tAppE et e) es


tVarE s t =  TVarE (mkName s) t
tWildE s t = TWildE (mkName s) t
-- constructs a partial application of 'a' to 'f', where 'f' must be a function 
-- expression with at least one argument
tAppE f a = TAppE f a

tInfixE l c r = tAppE (tAppE c l) r

tTupE :: [TExp] -> TExp
tTupE as = foldTAppE (TConE (tupleDataName (length as)) tupleCtorType) as
  where asTypes       = map typeOf as
        tupleCtorType = arrowT (asTypes ++ [tupT asTypes])

tListE []     t = TConE '[] t
tListE (x:xs) t = tAppE (tAppE (TConE '(:) $ arrowT [typeOf x, t, t]) x) (tListE xs t)

tConE n argtys = TConE n (arrowT argtys)

chkTConE f (TConE n _) = f n
chkTConE _ _           = False 

--mkTCondE i t e = TCondE i t e (typeOf e)

foldTInfixE [] _ = error "foldTInfixE: empty list of sections!"    
foldTInfixE sections lastarg = 
    foldr1 (.) sections $ lastarg