-- 
-- Copyright (C) 2005 Stefan Wehr - http://www.stefanwehr.de
--
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
-- published by the Free Software Foundation; either version 2 of
-- the License, or (at your option) any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
-- 

module Phrac.ParserHelper where

import Maybe (mapMaybe)

import Phrac.ParseSyntax
import Phrac.Pretty
import Phrac.Error
import Phrac.Builtins

data PrgElem = PrgTypeDef TypeDef
             | PrgClassDec ClassDec
             | PrgClassInst ClassInst
             | PrgBind ValBind

mkProgram :: [PrgElem] -> Program
mkProgram l = 
    Program types classes insts binds
    where
    types = mapMaybe (\e -> case e of PrgTypeDef d -> Just d; _ -> Nothing) l
    classes = mapMaybe (\e -> case e of PrgClassDec d -> Just d; _ -> Nothing) l
    insts = mapMaybe (\e -> case e of PrgClassInst d -> Just d; _ -> Nothing) l
    binds = mapMaybe (\e -> case e of 
                              PrgBind d 
                                -> Just (d { vbind_info = 
                                               (vbind_info d) { info_toplevel 
                                                                = True } })
                              _ -> Nothing) l

mkClassDec :: ([Constraint], Type) -> [AssocTypeSig] -> [VSig] -> ClassDec
mkClassDec (cs, t) tsigs vsigs =
    ClassDec i vs (map toClassConstraint cs) tsigs vsigs 
       (emptyInfo { info_toplevel = True })
    where toClassConstraint (CC cc) = cc
          toClassConstraint c@(_) = 
              phasefail ("illegal class constraint:" ++ show (ppr c))
          (i, vs) = let (i', ts) = case splitType t of
                                     Just x -> x
                                     Nothing ->
                                         phasefail ("illegal class declaration"
                                                    ++ showPpr' t)
                        f (TyVar id) = id
                        f _ = phasefail ("illegal class declaration " 
                                         ++ showPpr' i')
                        in (i', map f ts)

mkClassInst :: ([Constraint], Type) -> [AssocTypeBind] -> [ValBind] 
            -> ClassInst
mkClassInst (cs, t) assocs vals = 
    let (i, ts) = case splitType t of
                    Just x -> x
                    Nothing -> phasefail "illegal instance declaration"
        in ClassInst i ts cs assocs vals (emptyInfo { info_toplevel = True })

splitType :: Type -> Maybe (TypeId, [Type])
splitType (TyApp (TyConstruct i) t) = return (i, [t])
splitType (TyApp t1 t2) = 
    do (i, ts) <- splitType t1
       return (i, ts ++ [t2])
splitType t = fail ("cannot split type " ++ showPpr' t)

mkEqConstraint :: Type -> Type -> EqConstraint
mkEqConstraint t1 t2 = 
    let (name, params) = (fst $ splitConstr t1, reverse.snd $ splitConstr t1)
    in if null params 
          then phasefail ("Illegal AT in equality constraint: " ++
                          show (ppr t1))
          else EqConstraint (AssocType name params) t2
    where
    splitConstr (TyApp (TyConstruct tc) t) = (tc, [t])
    splitConstr (TyApp t1 t2) = 
	let (tc,ts) = splitConstr t1 in  (tc, t2:ts)

mkClassConstraint :: Type -> ClassConstraint
mkClassConstraint t = 
    let (i, ts) = case splitType t of
                    Just x -> x
                    Nothing -> phasefail ("Illegal class constraint: " ++
                                          show (ppr t))
        in ClassConstraint i ts

-- string contains leading and trailing double quote
mkStringList :: String -> Exp
mkStringList (_:s) = mk s
    where 
    mk (_:[]) = Con (fst nilDataConstructor) []
    mk (x:xs) = 
        let l = mk xs
            in Con (fst consDataConstructor) [Const (Character x), l]