{-# OPTIONS -fglasgow-exts #-} -- ^ for pattern guards -- -- Copyright (c) 2005 Gabriele Keller (keller@cse.unsw.edu.au) -- 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.SyntaxTransformation where import Monad (liftM, mapM, filterM) import qualified List import Maybe (mapMaybe) import qualified Data.Set as Set import qualified Phrac.AbstractSyntax as AS import qualified Phrac.Builtins as Builtins import Phrac.ParseSyntax import Phrac.Pretty import Phrac.Error import Phrac.UniqIdents as UniqIdents hiding (TypeVarId, TypeId, DataId, ClassId, AssocTypeId, ValId) transform :: Program -> IO AS.Program transform p = runNA (rw_programm p) -- Paper & Impl: -- --------------- -- prg ::= [cdecs] ";" [tyinst] ";" [bind] -- rw_programm:: Program -> NA AS.Program rw_programm (Program typedefs classdecs classinsts binds) = do -- add forward declarations (but only those which are really needed) mapM defineTypeDef typedefs mapM defineClass classdecs mapM defineToplevelFunction binds display "rewriting type definitions ..." typedefs' <- rw_typedefs typedefs display "rewriting class declarations ..." classdecs' <- rw_classdecs classdecs display "rewriting instance declarations ..." classinsts' <- mapM rw_classinst classinsts display "rewriting bindings ..." binds' <- mapM rw_toplevelBind binds return (AS.Program typedefs' classdecs' classinsts' binds') where defineTypeDef (TypeDef i _ _ _) = defineTypeCon i defineClass cd@(ClassDec name _ _ tsigs valsigs _) = do UniqIdents.defineClass name let n = length (class_params cd) mapM (\ sig -> defineAssocTypeCon (assocSig_name sig) n) tsigs defineToplevelFunction (ValBind fn _ _ _ _) = defineValVar fn rw_info :: Info -> AS.Info rw_info (Info builtin toplevel) = AS.Info builtin toplevel rw_typedefs:: [TypeDef] -> NA [AS.TypeDef] rw_typedefs = mapM rw_typedef rw_typedef:: TypeDef -> NA AS.TypeDef rw_typedef (TypeDef i args talts info) = do args' <- mapM defineTypeVar args uid <- lookUpTypeCon i talts' <- mapM (rw_talt $ info_builtin info) talts mapM undefineTypeVar args' return (AS.TypeDef uid args' talts' (rw_info info)) rw_talt :: Bool -> (DataConstructor) -> NA AS.DataConstructor rw_talt builtin (DataConstructor id args) = do uid <- defineDataCon id (length args) builtin args' <- mapM rw_type args return $ AS.DataConstructor uid args' rw_classdecs::[ClassDec] -> NA [AS.ClassDec] rw_classdecs = mapM rw_classdec rw_classdec:: ClassDec -> NA AS.ClassDec rw_classdec (ClassDec name params constrs tsigs vsigs info) = do uid <- lookUpClass name params' <- mapM defineTypeVar params constrs' <- mapM rw_classConstraint constrs tsigs' <- mapM rw_tsig tsigs vsigs' <- mapM rw_vsig vsigs mapM undefineTypeVar params' return $ AS.ClassDec uid params' constrs' tsigs' vsigs' (rw_info info) rw_tsig (AssocTypeSig id ts def) = do (uid, n) <- lookUpAssocTypeCon id let indices = take n ts params = drop n ts if length indices /= n then phasefail ("invalid declaration of associated type synonym " ++ showPpr' id) else return () indices' <- mapM lookUpTypeVar indices params' <- mapM defineTypeVar params def' <- case def of Nothing -> return Nothing Just x -> do x' <- rw_type x return (Just x') mapM undefineTypeVar params' return (AS.AssocTypeSig uid (indices' ++ params') def') rw_vsig:: VSig -> NA AS.VSig rw_vsig (i, sc) = do uid <- defineValVar i sc' <- rw_typeScheme sc return (uid, sc') -- Paper -- ------ -- classinst ::= "instance" constrScheme "where" atype ";" bind -- -- Impl -- ------ -- classinst ::= "instance" constrScheme "where" atype ";" [bind] -- rw_classinst:: ClassInst -> NA AS.ClassInst rw_classinst (ClassInst name params constrs tyBinds valBinds info) = do let vars = Set.toList $ freeTypeVars params vars' <- mapM defineTypeVar vars constrs' <- mapM rw_constraint constrs params' <- mapM rw_type params uid <- lookUpClass name tyBinds' <- mapM rw_assocTypeBind tyBinds valBinds' <- rw_classBinds valBinds mapM undefineTypeVar vars' return (AS.ClassInst uid params' constrs' tyBinds' valBinds' (rw_info info)) rw_classBinds:: [ValBind] -> NA [AS.ValBind] rw_classBinds = mapM rw_classBind where rw_classBind :: ValBind -> NA AS.ValBind rw_classBind (ValBind id (Just _) params exp _) = panic ("explicitly typed method binding should not be produced " ++ "by the parser") rw_classBind (ValBind id Nothing pats exp info) = do uid <- lookUpValVar id enterBlock pats' <- mapM rw_pattern pats exp' <- rwExp exp exitBlock return (AS.ValBind uid Nothing pats' exp' (rw_info info)) rw_pattern :: Pat -> NA AS.Pat rw_pattern (PVar v) = do v' <- defineValVar v return (AS.PVar v') rw_pattern p@(PCon id ps) = do (id', arity, _) <- lookUpDataCon id if length ps /= arity then phasefail ("illegal pattern " ++ showPpr' p ++ ". Data constructor " ++ showPpr' id ++ " takes " ++ show arity ++ " arguments, given: " ++ show (length ps)) else return () ps' <- mapM rw_pattern ps return (AS.PCon id' ps') rw_pattern (PAs id pat) = do pat' <- rw_pattern pat id' <- defineValVar id return (AS.PAs id' pat') rw_pattern PWildcard = return AS.PWildcard rw_classConstraint :: ClassConstraint -> NA AS.ClassConstraint rw_classConstraint cc = do AS.CC cc' <- rw_constraint (CC cc) return cc' rw_constraint:: Constraint -> NA AS.Constraint rw_constraint (CC (ClassConstraint i ts)) = do uid <- lookUpClass i ts' <- mapM rw_type ts return (AS.CC (AS.ClassConstraint uid ts')) rw_constraint (EC (EqConstraint (AssocType id params) t2)) = do (uid, _) <- lookUpAssocTypeCon id params' <- mapM rw_type params t2' <- rw_type t2 return (AS.EC (AS.EqConstraint (AS.AssocType uid params') t2')) -- the parser stores all parameter in indices rw_assocTypeBind :: AssocTypeBind -> NA AS.AssocTypeBind rw_assocTypeBind (AssocTypeBind id indices _ ty status) = do (uid, i) <- lookUpAssocTypeCon id let realIndices = take i indices params = drop i indices paramVars = mapMaybe maybeTypeVar params if length params /= length paramVars then phasefail ("illegal assoc type definition: at least one of the " ++ "additional parameters is not a type variable") else return () indices' <- mapM rw_type realIndices params' <- mapM defineTypeVar paramVars ty' <- rw_type ty mapM undefineTypeVar params' return (AS.AssocTypeBind uid indices' params' ty' (rw_status status)) where rw_status AssocTypeNotAbstract = AS.AssocTypeNotAbstract rw_status AssocTypeAbstract = AS.AssocTypeAbstract rw_typeScheme :: TypeScheme -> NA AS.TypeScheme rw_typeScheme (TypeScheme _ qtype@(QualifiedType _ t)) = do undef <- undefinedTypeVars qtype let free = undef `List.intersect` freeTypeVarsList t free' <- mapM defineTypeVar free qtype' <- rw_qualifiedType qtype mapM undefineTypeVar free' return (AS.TypeScheme free' qtype') rw_qualifiedType :: QualifiedType -> NA AS.QualifiedType rw_qualifiedType (QualifiedType constrs t) = do constrs' <- mapM rw_constraint constrs t' <- rw_type t return (AS.QualifiedType constrs' t') -- rw_type: -- * rewrite type -- rw_type:: Type -> NA AS.Type rw_type (TyVar v) = do uid <- lookUpTypeVar v return $ AS.TyVar uid -- we have to check if type constructor at the top of the -- application chain is a assoc type, and restructure it -- if necessary rw_type t@(TyApp t1 t2) = do res <- isAT t case res of Nothing -> do t1' <- rw_type t1 t2' <- rw_type t2 return (AS.TyApp t1' t2') Just (_, []) -> phasefail "Renamer" "AT not applied to anything" Just (id, args') -> let args = reverse args' assoc = AS.AssocType id args in return (AS.TyAssoc assoc) where isAT (TyConstruct tc) = do b <- isAssocTypeCon tc if b then do (uid,_) <- lookUpAssocTypeCon tc return (Just (uid, [])) else return Nothing isAT (TyApp t1 t2) = do at <- isAT t1 case at of Nothing -> return Nothing Just (tc, args) -> do t2' <- rw_type t2 return (Just (tc, t2':args)) isAT _ = return Nothing rw_type (TyConstruct id) = do uid <- lookUpTypeCon id return (AS.TyConstruct uid) rw_type (TyAssoc t@(AssocType id ts)) = do (uid,arity) <- lookUpAssocTypeCon id if length ts /= arity -- not sure if check really needed here, but does -- no harm anyway then phasefail "renamer" ("AT " ++ showPpr' t ++ " applied to wrong number of arguments. " ++ "Expected arity: " ++ show arity) else do ts' <- mapM rw_type ts return (AS.TyAssoc (AS.AssocType uid ts')) rwExp :: Exp -> NA AS.Exp rwExp (Var id) = do uid <- lookUpValVar id return (AS.Var uid) rwExp (Const (Number i)) = return (AS.Const (AS.Number i)) rwExp (Const (Character i)) = return (AS.Const (AS.Character i)) rwExp (Prim o es) = do rn_es <- mapM rwExp es return (AS.Prim o rn_es) rwExp (Con tg []) = do (tg', arity, builtin) <- lookUpDataCon tg let v = if builtin then "#v" else "v" vs <- mapM freshValVar (take arity $ repeat v) let con = AS.Con tg' (map AS.Var vs) if arity == 0 then return con else return (AS.Lam (map AS.PVar vs) con) rwExp (Con tg args) = do (tg', arity, _) <- lookUpDataCon tg if arity /= length args then panic ("arity mismatch in constructor expression with " ++ "non-empty argument list") else do args' <- mapM rwExp args return $ AS.Con tg' args' rwExp (Lam pats e) = do enterBlock pats' <- mapM rw_pattern pats e' <- rwExp e exitBlock return (AS.Lam pats' e') rwExp (If e e1 e2) = do e' <- rwExp e e1' <- rwExp e1 e2' <- rwExp e2 return (AS.If e' e1' e2') rwExp (Case e alts) = do e' <- rwExp e alts' <- mapM rwAlt alts return (AS.Case e' alts') where rwAlt (Alt pat e) = do enterBlock pat' <- rw_pattern pat e' <- rwExp e exitBlock return (AS.Alt pat' e') rwExp (App (App (Var v) e1) e2) | (Just op) <- Builtins.strToPrimOp v, Builtins.isBinPrimOp op = do e1' <- rwExp e1 e2' <- rwExp e2 return (AS.Prim op [e1',e2']) rwExp (App e1 e2) = do e1' <- rwExp e1 e2' <- rwExp e2 return (AS.App e1' e2') rwExp (Letrec binds e) = do enterBlock names <- mapM defineBind binds triples <- mapM rw_bind binds e' <- rwExp e exitBlock let binds' = map mkBind (zip names triples) return (AS.Letrec binds' e') type BindTuple = (Maybe AS.TypeScheme, [AS.Pat], AS.Exp, AS.Info) mkBind :: (AS.ValId, BindTuple) -> AS.ValBind mkBind (name, (ty, pats, e, info)) = AS.ValBind name ty pats e info defineBind :: ValBind -> NA AS.ValId defineBind (ValBind f _ _ _ _) = defineValVar f rw_bind :: ValBind -> NA BindTuple rw_bind (ValBind _ Nothing pats e info) = do enterBlock pats' <- mapM rw_pattern pats e' <- rwExp e exitBlock return (Nothing, pats', e', rw_info info) rw_bind (ValBind _ (Just ty) pats e info) = do enterBlock pats' <- mapM rw_pattern pats e' <- rwExp e exitBlock ty' <- rw_typeScheme ty return ((Just ty'), pats', e', rw_info info) rw_toplevelBind b@(ValBind f ty params e info) = do f' <- lookUpValVar f triple <- rw_bind b return (mkBind (f', triple)) undefinedTypeVars ty = filterM (liftM not . isDefinedTypeVar) (freeTypeVarsList ty)