{-# OPTIONS_GHC -XFlexibleInstances -XTemplateHaskell #-}
module Syntax.Builder (
    
    parseSpec
    

    )where



import qualified Data.Map as Map
import Data.List (partition, union,foldl', nub)

-- for translation
import qualified Data.Typeable as T (typeOf)
import Data.List (groupBy)
import Data.Function (on)
import Data.Generics (typeRepTyCon, Typeable(..))

import qualified Language.Haskell.Exts.Syntax as Hs
import Language.Haskell.Exts.Parser
import Language.Haskell.Exts.Extension
--import qualified Language.Haskell.TH.Syntax as TH (Type(..))
--import Syntax.IFTemplateHaskell hiding (Type(..))
--

import Generics.Pointless.Functors (Mu)

import Control.Monad.Reader
import Control.Monad.Error

import Syntax.UnifyTy
import Syntax.Expressions
import Syntax.Type
import Syntax.Name
import Syntax.Ppr
import Syntax.Class.Term
--
import Syntax.Specification
import Syntax.Context ( Context(..), emptyContext, defaultContext, C, 
                         getCtors, getType, withC) 

-------------------------------------------------------------------------------
-- Building Context
--------------------------------------------------------------------------------



parseSpec :: String ->  IO Specification
parseSpec s = do
    (bnds,decls) <- liftM bindsNdecls $ parse s
    spec <- foldM updateCtx (emptySpec defaultContext) decls
    spec' <- foldM processBnd spec bnds
    return  spec'
    -- add function bindings after data decls and instance decls
    where
    parse s = do f <- readFile s  
                 let mode = defaultParseMode{ parseFilename = s
                                            , extensions=[EnableExtension TypeOperators,
                                                          EnableExtension TypeFamilies]}
                 case parseModuleWithMode mode f of 
                    (ParseOk r) -> return r
                    (ParseFailed sloc msg) -> 
                        fail $ "Parsing failed at " ++ (show sloc) ++ 
                               " with message: " ++ msg  ++
                               "\nMaybe This is not supported by Igor."

bindsNdecls = (partition isFunBind) . moduleDecls
    where    
    isFunBind e = case e of (Hs.FunBind _ ) -> True; _ -> False
    moduleDecls (Hs.Module _ _ _ _ _ _ d) = d
 
processBnd :: Specification -> Hs.Decl -> IO Specification
processBnd spc d@(Hs.FunBind ms ) = do
    toFunBind (spec_ctx spc) ms  >>= return . (flip addToBindings spc)
processBnd spc d = do
    putStrLn $ errorMsg "Skipping processBnd: " d
    return spc     
        
updateCtx :: Specification -> Hs.Decl -> IO Specification
updateCtx spc d@(Hs.TypeDecl _ n tvb ty) = 
    let synTy = toType $ mkHsTyApp n tvb
    in return $ addToTypeSyns [(synTy, toType ty)] spc    
updateCtx spc (Hs.DataDecl sloc _ assts tname args condecls derive) = do
    let dataty = mkHsTyApp tname args
        -- build the type of the given data type
        ctorty = \ty -> (mkForallT assts (toType $ mkHsTyFun (ty ++ [dataty])))
        -- for a given list of ctor argument types it creates a function type 
        ctorNameTy (Hs.QualConDecl _ _ _ cd) = case cd of 
            (Hs.ConDecl n tys) ->  return ( toName n, ctorty $ map unBang tys);
             _owise -> fail $ noSupport "Record" sloc 
        -- extracts the name and the type of a constructor from a 'ConDecl'    
    pNameTy <- mapM ctorNameTy condecls
        -- pairs of function names and the types of accordant function 
    let toTyClass (n,[]) = return $ (mkForallT assts (toType dataty), (toName n)) 
        toTyClass (n,_)  = fail $ noSupport "Multi-parameter type classes" sloc
    tyClasses <- mapM toTyClass derive
        -- pairs of types 't' and class name 'c', denoting 't' isInstanceOf 'c'
    return $ (addToConstructors [(toName tname, map fst pNameTy)]) . (addToTypes pNameTy) . (addToInstances tyClasses) $ spc
--updateCtx spc (Hs.ClassDecl sloc _ _ [] _ _) = can never be
updateCtx spc (Hs.ClassDecl sloc _ _ (_:_:_) _ _) =
    fail $ noSupport "Multi-parameter type classes" sloc
updateCtx spc (Hs.ClassDecl sloc _ _ _ [_] _) =
    fail $ noSupport "Functional Dependencies" sloc
updateCtx spc (Hs.ClassDecl sloc assts cn as _ ds) = do
    let cdecls d = 
         case d of 
          (Hs.ClsDecl dcl) -> [dcl] ;
          -- [] was before: fail $ noSupport "Associated data types or type synonyms" sloc
           _owise -> []
        getName (Hs.KindedVar n _) = n 
        getName (Hs.UnkindedVar n) = n
        sigds        = concatMap (filter isTypeDecl) (map cdecls ds)
        -- extract type signatures 'TypeSig'
        isTypeDecl d = case d of (Hs.TypeSig _ _ _) -> True; _owise -> False
        assts'       = (mkHsAsst cn (map getName as)):assts 
        -- add actual class as additional assertion predicate in the signature of
        -- the class member functions
        pNameTy     = concatMap (\(Hs.TypeSig _ ns ty) -> (zip (map toName ns)(cycle [(toType ty)]))) sigds
        -- pairs of function names and the types of accordant function 
        pClssFuns     = [(toName cn,concat [ map toName n | (Hs.TypeSig _ n _) <- sigds])]
        -- pairs of a class name and a list of names of its member functions
        pClssSupr   = [(toName cn, concatMap (getVarNames . predMember) (getPreds assts))]
    return $ (addToTypes pNameTy ) . (addToMembers pClssFuns) . (addToClasses pClssSupr) $ spc
--updateCtx _ (Hs.InstDecl sloc _ _ _ _ [] _) -- can never be
updateCtx _ (Hs.InstDecl sloc _ _ _ _ (_:_:_) _) =
    fail $ noSupport "Multi-parameter type classes" sloc
updateCtx spc (Hs.InstDecl _ _ sloc assts qname [t] _) = do
    let ty = mkForallT assts (toType t)
        -- the type of the class instance
        n = toName qname
        -- the name of the class
    return $ addToInstances [(ty,n)] spc      
updateCtx spc (Hs.TypeSig _ ns ty) =
    return $ addToTypes (zip (map toName ns)(cycle [(toType ty)])) spc       
updateCtx spc (Hs.TypeInsDecl _ _ _) =
    -- noop
    return spc
updateCtx spc d = do
    putStrLn $ errorMsg "Skipping updateCtx:" d
    return spc
    
mkHsTyApp :: Hs.Name -> [Hs.TyVarBind] -> Hs.Type
mkHsTyApp n as = foldl Hs.TyApp (Hs.TyCon $ Hs.UnQual n) (map mkTyVar as)
    where 
    mkTyVar (Hs.KindedVar n _) = Hs.TyVar n
    mkTyVar (Hs.UnkindedVar n) = Hs.TyVar n 

mkHsTyFun :: [Hs.Type] -> Hs.Type
mkHsTyFun = foldr1 Hs.TyFun

mkHsAsst :: Hs.Name -> [Hs.Name] -> Hs.Asst
mkHsAsst ctor args = Hs.ClassA (Hs.UnQual ctor)( map Hs.TyVar args)

unBang :: Hs.Type -> Hs.Type
unBang (Hs.TyBang bang ty) = ty
unBang ty                  = ty

mkForallT :: [Hs.Asst] -> Type -> Type
mkForallT assts ty   =
    fixType $ ForallT (getPreds assts) ty


--------------------------------------------------------------------------------
-- Translating 
--------------------------------------------------------------------------------

-- | Propagates a type to an expression and all its subexpressions. 
--   No type checking is done !!         
class ToTExp t     where toTExp   :: (Error e, MonadError e m) => Type -> t -> C m TExp
class ToFunBind d  where toFunBind :: (Error e, MonadError e m) => Context -> d -> m [FunBind]
class ToEquation d where toEquation :: (Error e, MonadError e m) => Type -> d -> C m Equation
class ToName a where toName :: a -> Name
class ToLit  a where toLit  :: a -> Lit
class ToType a where toType :: a -> Type

instance ToFunBind [Hs.Match] where
    toFunBind c ms = mapM (toFunBind c) ms >>= return . concat  >>=
                      return . (groupBy $ on (==) fName) >>=
                       return . (map (\fs -> FunB (fName . head $ fs) (concatMap fEqus fs)))

instance ToFunBind Hs.Match where
    toFunBind c (Hs.Match _ n lhs _ty rhs bs)
        | emptyBinds bs = let n' = toName n in 
            case Map.lookup n' (ctx_types c)of
             (Just ty) -> withC (toEquation ty (lhs,rhs)) c >>= \e -> 
                            return [FunB n' [e]]
             Nothing   -> throwError . strMsg $ "No type in Context for '" ++ show n ++"'"
        | otherwise     = throwError . strMsg $ "Binding geroups inside a let ot where clause are not supported."
        
emptyBinds (Hs.BDecls l)  = null l
emptyBinds (Hs.IPBinds l) = null l
      
instance ToEquation ([Hs.Pat],Hs.Rhs) where
    toEquation ty (lhs,rhs) = do
        let argty = unArrowT ty
        ls <- zipWithM toTExp (init argty) lhs
        case rhs of
            (Hs.UnGuardedRhs rhs') -> toTExp (last argty) rhs' >>= return . (UnGuardEq ls)
            (Hs.GuardedRhss rhss) -> mapM (mkRhs (last argty)) rhss >>= return . (GuardedEq ls)

mkRhs ty (Hs.GuardedRhs _ [g] e) = liftM2 (,) (toTExp (conT ''Bool) g) (toTExp ty e)
mkRhs _ _ = fail "Pattern Guards are not supported!" 
        

instance ToTExp Hs.Exp where
    toTExp t (Hs.Var n)          = return $ TVarE (toName n) t
    toTExp t (Hs.Lit l)          = return $ TLitE (toLit l) t
    toTExp t (Hs.Con n)          = return $ TConE (toName n) t
    toTExp lstty (Hs.List l)     = do
        let [elemty] = unfoldAppTargs lstty
        tes <- mapM (toTExp elemty) l
        return $ tListE tes lstty
    toTExp tupty (Hs.Tuple _ l)      = do
        let tuptys = unfoldAppTargs tupty
        tes <- zipWithM toTExp tuptys l
        return $ tTupE tes
    toTExp t e@(Hs.App _ _ ) =
        case unfoldApp e of
            ((Hs.Var n):args) -> do -- a function name
                let n' = toName n
                ty <- getType n' >>= maybe (throwError . strMsg $ "Fun " ++ show n' ++ " not in Context") (specialise t)
                tyargs <- return $ unArrowT ty
                teargs <- zipWithM toTExp tyargs args
                return $ foldTAppE (TVarE n' ty) teargs     
            ((Hs.Con n):args) -> do
                let n' = toName n
                ty <- getType n' >>= maybe (throwError . strMsg $ "Ctor " ++ show n' ++ " not in Context") (specialise t)
                let tys = unArrowT ty
                teargs <- zipWithM toTExp tys args
                return $ foldTAppE (tConE n' tys) teargs          
    toTExp t e@(Hs.InfixApp (Hs.InfixApp _ _ _) _ _) = 
      -- InfixApp is lassoc, TInfixE is rassoc!!!
      toTExp t (fixInfixApp e)                      
    toTExp t (Hs.InfixApp l qop  r) = do 
        let n' = toName qop
        ty <- getType n' >>= maybe (throwError . strMsg $ "Ctor " ++ show n' ++ " not in Context") (specialise t)
        let tys@(ty1:ty2:_) = unArrowT ty
        l' <- toTExp ty1 l
        r' <- toTExp ty2 r
        return $ tInfixE l' (tConE n' tys) r'  
    toTExp t (Hs.Paren e) = toTExp t e
    toTExp _ e =  throwError . strMsg $ errorMsg "toTExp" e

instance ToTExp Hs.Pat where
    toTExp t (Hs.PLit sign l) = liftM (flip TLitE t) (applysign sign (toLit l))
        where applysign Hs.Signless lit      = return lit
              applysign Hs.Negative (Int n)  = return $ Int (negate n)
              applysign Hs.Negative (Frac r) = return $ Frac (negate r)
              applysign Hs.Negative _        = throwError . strMsg $ "cannot negate char or string literal"
    toTExp t (Hs.PVar n) = return $ TVarE (toName n) t
    toTExp tupty (Hs.PTuple _ l) = do
        let tuptys = unfoldAppTargs tupty
        tes <- zipWithM toTExp tuptys l 
        return $ tTupE tes
    toTExp t (Hs.PApp n args) = do 
        let n' = toName n
        ty <- getType n' >>= maybe (throwError . strMsg $ "Ctor " ++ show n' ++ " not in Context") (specialise t)
        tyargs <- return $ unArrowT ty
        teargs <- zipWithM toTExp tyargs args
        return $ foldTAppE (tConE n' tyargs) teargs
    toTExp lstty (Hs.PList l) = do
        let [elemty] = unfoldAppTargs lstty
        tes <- mapM (toTExp elemty) l
        return $ tListE tes lstty
    toTExp t e@(Hs.PInfixApp (Hs.PInfixApp _ _ _) _ _) =
      -- PInfixApp is lassoc, RInfixE is rassoc!!!
      toTExp t (fixPInfixApp e)      
    toTExp t (Hs.PInfixApp l n r) = do
        let n' = toName n
        ty <- getType n' >>= maybe (throwError . strMsg $ "Ctor " ++ show n' ++ " not in Context") (specialise t)
        let tys@(ty1:ty2:_) = unArrowT ty
        l' <- toTExp ty1 l
        r' <- toTExp ty2 r
        return  $ tInfixE l' (tConE n' tys) r'  
    toTExp t (Hs.PParen e) = toTExp t e    
    toTExp _ p = throwError . strMsg $ errorMsg "toTExp" p

instance ToTExp Hs.Stmt where
    toTExp ty (Hs.Qualifier e) = toTExp ty e
    toTExp _ s = throwError . strMsg $ errorMsg "toTExp" s

errorMsg :: (Show a,Typeable a) => String -> a -> String
errorMsg fun a = concat
  [ fun, " ", (show a), ":: "
  , show . typeRepTyCon . T.typeOf $ a
  , " not (yet?) implemented"
  ]
  
noSupport :: (Show a) => String -> a -> String
noSupport s sloc = "Not supported: " ++ s ++ " at: " ++ (show sloc)

--
-------------------------------------------------------------------------------
--
--
--instance ToExp Lit where
--  toExp = LitE
--instance (ToExp a) => ToExp [a] where
--  toExp = ListE . fmap toExp
--instance (ToExp a, ToExp b) => ToExp (a,b) where
--  toExp (a,b) = TupE [toExp a, toExp b]
--instance (ToExp a, ToExp b, ToExp c) => ToExp (a,b,c) where
--  toExp (a,b,c) = TupE [toExp a, toExp b, toExp c]
--instance (ToExp a, ToExp b, ToExp c, ToExp d) => ToExp (a,b,c,d) where
--  toExp (a,b,c,d) = TupE [toExp a, toExp b, toExp c, toExp d]
--
--
--instance ToPat Lit where
--  toPat = LitP
--instance (ToPat a) => ToPat [a] where
--  toPat = ListP . fmap toPat
--instance (ToPat a, ToPat b) => ToPat (a,b) where
--  toPat (a,b) = TupP [toPat a, toPat b]
--instance (ToPat a, ToPat b, ToPat c) => ToPat (a,b,c) where
--  toPat (a,b,c) = TupP [toPat a, toPat b, toPat c]
--instance (ToPat a, ToPat b, ToPat c, ToPat d) => ToPat (a,b,c,d) where
--  toPat (a,b,c,d) = TupP [toPat a, toPat b, toPat c, toPat d]
--
--
--instance ToLit Char where
--  toLit = CharL
--instance ToLit String where
--  toLit = StringL
--instance ToLit Integer where
--  toLit = IntegerL
--instance ToLit Int where
--  toLit = IntegerL . toInteger
--instance ToLit Float where
--  toLit = RationalL . toRational
--instance ToLit Double where
--  toLit = RationalL . toRational
--


instance ToLit Hs.Literal where
  toLit (Hs.Char a)   = Char a
  toLit (Hs.String a) = String a
  toLit (Hs.Int a)    = Int a
  toLit (Hs.Frac a)   = Frac a
-----------------------------------------------------------------------------


-- * ToName {String,HsName,Module,HsSpecialCon,HsQName}


instance ToName String where
  toName = mkName

instance ToName Hs.QName where
    toName (Hs.Qual (Hs.ModuleName m) n) = toName $ m ++ "." ++ 
                                                    (show.pretty.toName $ n)
    toName (Hs.UnQual n)                 = toName n
    toName (Hs.Special s)                = toName s
    
instance ToName Hs.SpecialCon where
    toName Hs.UnitCon        = '()
    toName Hs.ListCon        = '[]
    toName Hs.FunCon         = ''(->)
    toName Hs.Cons           = '(:)
    toName (Hs.TupleCon _ n)
        | n<2                = '()
        | otherwise          =  toName . concat $ ["(",replicate (n-1) ',',")"]
    toName s                 = error $ "toName: Symbol " ++ (show s) ++ " is not supported"
    

instance ToName Hs.Name where
  toName (Hs.Ident s) -- = toName s
  -- need to code it the hard way to make sure to get the right thing
    | s == "Maybe"   = ''Maybe
    | s == "Mu"      = ''Mu
    | s == "Just"    = 'Just
    | s == "Nothing" = 'Nothing
    | s == "Either"  = ''Either
    | s == "Left"    = 'Left
    | s == "Right"   = 'Right
    | s == "Bool"    = ''Bool
    | s == "True"    = 'True
    | s == "False"   = 'False
    | otherwise      = toName s
  toName (Hs.Symbol s) = toName s

instance ToName Hs.Module where
  toName (Hs.Module _ (Hs.ModuleName m) _ _ _ _ _) = toName m



instance ToName Hs.QOp where
    toName (Hs.QVarOp n) = toName n
    toName (Hs.QConOp n) = toName n 

instance ToType Hs.Type where
  toType (Hs.TyForall Nothing x t) = fixType $ ForallT (getPreds x) (toType t)
  toType a@(Hs.TyForall _ _ _)     = error $ errorMsg "toType" a
  toType (Hs.TyFun a b)            = toType a .->. toType b
  toType (Hs.TyTuple _ ts)         = tupT $ fmap toType ts
  toType (Hs.TyList t)             = listT $ toType t
  toType (Hs.TyApp a b)            = appT (toType a) (toType b)
  toType (Hs.TyVar n)              = VarT (toName n)
  toType (Hs.TyCon n)              = ConT (toName n)
  toType (Hs.TyParen t)            = toType t
  toType (Hs.TyKind t _)           = toType t
  toType (Hs.TyInfix l c r)        = infixT (ConT . toName $ c)(toType l)(toType r)

(.->.) :: Type -> Type -> Type
a .->. b = arrowT [a, b]

getPreds :: Hs.Context -> TyCxt
getPreds = concatMap getPred
    where
    getPred (Hs.ClassA n ts) = map (Pred (toName n) . toType) ts
    getPred p             = error $ errorMsg "toType" p

-- | Returns only the arguments of an 'AppE'xpression.
unfoldAppArgs = tail . unfoldApp

-- | Peals the @Exp@s out of a @AppE@, where the first element should be the 
--   @ConE@ of the function name or the constructor.
unfoldApp :: Hs.Exp -> [Hs.Exp]
unfoldApp e = f [] e
    where 
    f done e =
        case e of
            (Hs.App e1@(Hs.Var _) e2) -> e1:e2:done
            (Hs.App e1@(Hs.Con _) e2) -> e1:e2:done
            (Hs.App e1 e2)       -> f (e2:done) e1
            _owise             -> e:done
 
foldApp :: [Hs.Exp] -> Hs.Exp
foldApp es = foldl1 Hs.App es


fixPInfixApp :: Hs.Pat -> Hs.Pat
fixPInfixApp (Hs.PInfixApp (Hs.PInfixApp ll n1 lr) n2 r) = 
    fixPInfixApp  (Hs.PInfixApp ll n1 (Hs.PInfixApp lr n2 r))
fixPInfixApp (Hs.PInfixApp l n r) = (Hs.PInfixApp l n (fixPInfixApp r))
fixPInfixApp e = e

fixInfixApp :: Hs.Exp -> Hs.Exp
fixInfixApp (Hs.InfixApp (Hs.InfixApp ll n1 lr) n2 r) = 
    fixInfixApp  (Hs.InfixApp ll n1 (Hs.InfixApp lr n2 r))
fixInfixApp (Hs.InfixApp l n r) = (Hs.InfixApp l n (fixInfixApp r))
fixInfixApp e = e
-----------------------------------------------------------------------------