{- |
   This module contains functions for converting a 'Language.Haskell.Parser.ParseResult'
   to our own representation of a Haskell module called 'SimpleHaskell'.
-}

module GraphRewrite.Internal.Convert
where

import GraphRewrite.Internal.SimpleHaskell

import Data.List
import Data.Char

import Language.Haskell.Syntax
import Language.Haskell.Parser

-- | Converts a 'ParseResult' as returned by 'Language.Haskell.Parser' to our internal 'SimpModule' format. Returns an empty 'SimpModule' if the parse failed.
convParse :: ParseResult HsModule -> SimpModule String
convParse (ParseFailed _ _) = []
convParse (ParseOk m)       = convModule m

splitDecls :: [HsDecl] -> ([HsDecl], [HsDecl])
splitDecls l = partition isEnvRelated l
    where
      isEnvRelated d = case d of
                         (HsDataDecl _ _ _ _ _ _) -> True
                         (HsTypeDecl _ _ _ _) -> True
                         _ -> False


convModule :: HsModule -> SimpModule String
convModule (HsModule _ _m _exp _imp decl) = map convDecl (snd $ splitDecls decl)

convDecl :: HsDecl -> Decl String
convDecl (HsFunBind hsmatch) = FunBind (map convMatch hsmatch)
convDecl (HsPatBind _ pat rhs _decl) = PatBind (convPars pat) (convRhs rhs)
--convDecl (HsDataDecl _ _ (HsIdent a) _ _ _) = DataDecl a
--convDecl (HsDataDecl _ _ (HsSymbol a) _ _ _) = DataDecl a

convMatch :: HsMatch -> FunAlt String
convMatch (HsMatch _ (HsIdent fname) pars expr _) = (fname, map convPars pars, convRhs expr)

convPars :: HsPat -> Patt String
convPars (HsPVar n) = convName n
convPars (HsPLit n) = Lit (convLit n)
convPars (HsPApp qn l) = Apply $ (convQName qn) : (map convPars l)
convPars (HsPParen p) = convPars p
convPars (HsPAsPat n p) = AsPat (head $ nameExpr $ convName n) (convPars p)
--convPars (HsPNeg n) --TBD
convPars (HsPList []) = Cons "[]"
convPars (HsPInfixApp p1 p2 p3) = convPars (HsPApp p2 [p1,p3])
convPars p = error $ "convPars: " ++ show p

convName :: HsName -> Expr String
convName (HsIdent  n)
    | isUpper (head n) = Cons n
    | otherwise        = Var n
convName (HsSymbol n) = Var n --FIXME

convQName :: HsQName -> Expr String
convQName (UnQual n) = convName n
--convQName Qual m n
convQName (Special HsCons) = Cons ":"
convQName (Special HsListCon) = Cons "[]"


convLit :: HsLiteral -> String
convLit (HsChar n) = show n
convLit (HsString n) = show n
convLit (HsInt n) = show n
convLit (HsFrac n) = show n
convLit (HsCharPrim n) = show n
convLit (HsStringPrim n) = show n
convLit (HsIntPrim n) = show n
convLit (HsFloatPrim n) = show n
convLit (HsDoublePrim n) = show n

convRhs :: HsRhs -> Expr String
convRhs (HsUnGuardedRhs expr) = convExpr expr

convExpr :: HsExp -> Expr String
convExpr (HsVar qn) = convQName qn
convExpr (HsApp exp1 exp2)  = Apply [convExpr exp1, convExpr exp2]
convExpr (HsInfixApp exp1 (HsQVarOp qn) exp2) = Apply [convQName qn, convExpr exp1, convExpr exp2]
convExpr (HsInfixApp exp1 (HsQConOp qn) exp2) = Apply [convQName qn, convExpr exp1, convExpr exp2]
convExpr (HsLit literal)    = Lit (convLit literal)
convExpr (HsLet decls exp)  = Let (map convDecl decls) (convExpr exp)
convExpr (HsCon (UnQual (HsIdent con))) = Cons con
convExpr (HsParen exp) = convExpr exp
convExpr (HsList []) = Cons "[]"
convExpr a = Lit ("UNIMPLEMENTED: " ++ show a)