-- Implementation of SLNT ------------------------------------------------------------------------------ --import Flat --import List ------------------------------------------------------------------------------ -- encapsulating the state during the peval process: -- the state contains: -- * the list of all function declarations -- * the list of all used variable names -- * index for renamed variables -- * number of allowed unfoldings of function calls data PEvalState = PEState [FuncDecl] Int Int getFuncDecls (PEState fds _ _) = fds getRenamingIndex (PEState _ i _) = i getDepth (PEState _ _ d) = d updateRenamingIndex (PEState fds _ d) i = (PEState fds i d) incrDepth (PEState fds i d) = (PEState fds i (d+1)) -- local criteria to proceed unfolding a call at a given state: proceedUnfold pst (Comb FuncCall f args) nom= (getDepth pst < 100) && ((elem fn prelude_func)|| (is_lambda f nom)) where fn= delete_nom (nom++"_") f --proceedUnfold pst (Comb FuncCall f _) _= (getDepth pst < 100) -- Check if all the arguments are not literals. not_are_const (x:xs) = (not_is_const x)&&( first (not_are_const xs)) not_are_const [] =True not_is_const (Lit _)= False not_is_const (Comb ConsCall _ args) = not_are_const args not_is_const _ = True -- Para quitar el nombre del fichero del nombre de la funcion delete_nom (x:xs) (y:ys) = if x==y then delete_nom xs ys else (y:ys) delete_nom [] x = x is_lambda f nom= is_prefix (nom++"_"++nom++"_"++"lambda") f is_prefix (x:xs) (y:ys)= if (x==y) then is_prefix xs ys else False is_prefix [] x = True ------------------------------------------------------------------------------ -- main :: String -> Int ->[Int]-> IO () -- Atencion los numeros no indican nada, solo dejo los parametros -- por si los necesitara en el futuro -- main p pos lact = readFlatCurry p >>= \prog -> main p = readFlatCurry p >>= \prog -> putStrLn ("\nStarting deforestation for program \""++p++"\"...\n") >> go_transform prog p go_transform prog p = pprf2 (res) p >> -- write the flatcurry file ppRule (res) -- print the result where res=actlist prog 1 [2] p -- ppRule(actlist prog pos (rev lact) ) -- ppRule (transProg0 prog prog pos act) -- putStrLn (ppExpr 0 (pevalProg prog e)) -- reverse of a list rev (x:xs) = (rev xs) ++ [x] rev [] = [] -- Apply the list of actions --actlist prog pos (x:xs)= transProg pr2 pr2 pos x -- where pr2 = actlist prog pos xs --actlist prog _ [] = prog --Now we only apply the action 2 which covers all the actions actlist prog pos _ p= transProg prog prog pos 2 p ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- Se realiza una accion y se busca si es un foldr, si es asi -- se lanza un unfold (al haber un foldr deplegara todo)y un fobu --pt :: Prog -> Int -> Int->Prog --pt prg pos act = if find==1 then transProg tpr tpr pos 3 -- else tpr -- where (tpr,find)= pt2 prg pos act --pt2 prg pos act = if (find_fol tpr pos)==1 then (transProg tpr tpr pos 2, 1) -- else (tpr,0) -- where tpr= transProg prg prg pos act find_fol (Prog _ _ _ _ fun _) pos = sear_fun fun pos sear_fun (x:xs) pos= if pos-1==0 then f_fo1 x else sear_fun xs (pos-1) f_fo1(Func _ _ _ rul) = f_fo2(rul) f_fo2(Rule _ ex) = first (tfold ex) tfold (Comb FuncCall c _) = if c=="foldr" then 1 else 0 tfold _ = 0 -- ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ --transProg :: Prog -> Prog -> Int -> Int->Prog transProg (Prog x1 x2 x3 x4 funs x6) p _ act nom = (Prog x1 x2 x3 x4 funs_new x6) where funs_new=all_fun nfun p act nom nfun=all_fun_diff funs p act nom -- where funs_new=search_fun funs p pos act -- Lanza la accion solo para las regla determinada por "pos" --search_fun (x:xs) p pos act= if pos-1==0 then [x1]++xs -- else [x]++(search_fun xs p (pos-1) act) -- where x1=change_Fun x p act -- Lanza la accion para todas las funciones del programas all_fun (x:xs) p act nom = [x1] ++ (all_fun xs p act nom) where x1=change_Fun x p act nom all_fun [] _ _ _= [] --change_Funs funs p pos= [x1]++xs where x1=change_Fun x p -- Para la funcion indicada realiza la accion hasta que no se pueda -- aplicar mas change_Fun (Func x1 x2 x3 Rule1) p act nom = if Rule_new ==Rule1 then (Func x1 x2 x3 Rule_new) else change_Fun (Func x1 x2 x3 Rule_new) p act nom where Rule_new= change_Rule Rule1 p act nom change_Rule (Rule x1 e) p act nom = if ( first (no_case_const e_new)) then (Rule x1 e_new) else (Rule x1 e) where e_new=pevalProg p e act nom --Check if the expression is a valid case no_case_const (Case _ (Var _) _) = True no_case_const (Case _ _ _) = False no_case_const x = True -- Discrminador de accion a realizar, viene indicado por act -- 0 ->nada -- 1 ->Simplificaciones simples -- 2 ->Unfolding -- 3 -> Foldr/build pevalProg :: Prog -> Expr -> Int->String->Expr pevalProg (Prog a b c d funs f) e act nom = if act==0 then e else if act==1 then (first (peval0 (PEState funs (maxVarIndex e) 0) e)) else if act==2 then (first (unf (PEState funs (maxVarIndex e) 0) e (Prog a b c d funs f) nom)) else if act==3 then (first (fobu(PEState funs (maxVarIndex e) 0) e) nom) else no_apply (PEState funs (maxVarIndex e) 0) e (Prog a b c d funs f) nom ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- Prelude functions with foldr/build prelude_func=["append","lengthn","last","sum","mapn","from","app","allonesn","build"] --prelude_func=[] --Transformacion foldr-build -- Tan solo se realiza si la funcion outermost de la parte derecha es foldr -- y el tercer argumento de foldr es build fobu _ (Var v) _= (Var v) fobu _ (Lit l) _= (Lit l) fobu _ (Comb ConsCall c es) _ = (Comb ConsCall c es) fobu _ (Comb PartCall c es) _ = (Comb PartCall c es) -- HNF: FunEval: -- Se comprueba que la funcion es foldr, si es asi se continua fobu pst (Comb FuncCall c es) nom = if (c=="foldr") then f_build pst es nom else (Comb FuncCall c es) f_build pst (x1:x2:x3:_) nom = t_build pst x3 x1 x2 nom t_build _ (Comb FuncCall c (x:es)) x1 x2 nom = if c==(nom++"_"++"build") then deforest1 x x1 x2 else (Comb FuncCall c (x:es) ) t_build _ (Comb PartCall c (x:es)) x1 x2 nom = if c==(nom ++"_"++"build") then deforest1 x x1 x2 else (Comb PartCall c (x:es) ) --deforest pst x ([x1]++[x2]) deforest _ (Comb PartCall s args) x = (Comb FuncCall s (args++x)) deforest _ (Comb FuncCall s args) x = (Comb FuncCall s (args++x)) deforest1:: Expr->Expr->Expr->Expr deforest1 (Comb FuncCall s args) x1 x2 = Apply (Apply (Comb FuncCall s (args)) (x1)) (x2) deforest1 (Comb PartCall s args) x1 x2 = Apply (Apply (Comb PartCall s (args)) (x1)) (x2) search_arity (Prog _ _ _ _ fun _) fun_name = sear_fun_ar fun fun_name sear_fun_ar (x:xs) fun_name = if finda == (-1) then sear_fun_ar xs fun_name else finda where finda=cmp_funs x fun_name cmp_funs (Func namef arity _ _) f2 = if f2==namef then arity else (-1) f_fo1(Func _ _ _ rul) = f_fo2(rul) no_apply::PEvalState->Expr->Prog->String->Expr no_apply pst ex prg nom = if x==1 then rmv_partcall s args prg nom else head args where (args,s,x) = rmv_apply pst ex prg nom rmv_partcall::[Char]->[Expr]->Prog->String->Expr rmv_partcall s args prg _= if (length args == search_arity prg s) then (Comb FuncCall s args) else (Comb PartCall s args) rmv_apply::PEvalState->Expr->Prog->String->([Expr],[Char],Int) rmv_apply pst (Apply ex1 ex2) prg nom = if x==1 then (arg++[ex2],s,x) else ([Apply (head arg) ex2],s,x) where(arg,s,x)= rmv_apply pst ex1 prg nom rmv_apply pst (Comb FuncCall s arg) prg nom = ([first (unf pst (Comb FuncCall s arg) prg nom)],s,2) rmv_apply _ (Comb PartCall s arg) _ _= (arg,s,1) rmv_apply _ (Comb ConsCall s arg) _ _= ([(Comb ConsCall s arg)],s,2) rmv_apply _ (Var v) _ _=([(Var v)],"var",2) rmv_apply _ (Lit e) _ _=([(Lit e)],"lit",2) rmv_apply _ (Constr vars e) _ _=([(Constr vars e)],"const",2) rmv_apply _ (Or e1 e2) _ _= ([(Or e1 e2)],"or",2) rmv_apply pst (Case w e cases) prg nom= ([first (unf pst (Case w e cases) prg nom)],"case",2) rmv_apply _ (GuardedExpr vars c e) _ _= ([(GuardedExpr vars c e)],"guar",2) rmv_apply _ (Choice e) _ _= ([(Choice e)],"choi",2) -- encapsulated search.. first eval flex first g = head (findall (\x -> g =:= x)) --firstf (x:_) = first (t_fun x) --first (x:_) = "pepe" --t_fun (Comb ctype s _) = s --t_fun _ = "pepe2" -- Falta determinar la utilidad de este caso en fobu.... fobu pst (Case ctype (Comb combtype f es) ces) _= if combtype==FuncCall then peval_casefun (incrDepth pst) ctype f es ces -- Case Fun else (Case ctype (Comb combtype f es) ces) -- stop unfolding fobu _ (Case ctype (Var v) ces) _= (Case ctype (Var v) ces) fobu _ (Case ctype (Case ct e cet) ces) _= (Case ctype (Case ct e cet) ces) fobu _ f _=f ---------------------------------------------------------------------------- ---------------------------------------------------------------------------- unf_list _ [] _ _= [] unf_list pst [e1,e2,e3] prg nom= [e1,e2, (unf pst e3 prg nom)] unf::PEvalState->Expr->Prog->String->Expr unf _ (Var v) _ _= (Var v) unf _ (Lit l) _ _= (Lit l) unf _ (Comb ConsCall c es) _ _= (Comb ConsCall c es) unf _ (Comb PartCall c es) _ _= (Comb PartCall c es) -- HNF: FunEval: --unf_list pst [] _ = [] --unf_list pst [e1,e2,e3] prg = [e1,e2, (unf pst e3 prg)] --unf::PEvalState->Expr->Prog->Expr unf _ (Var v) _ _= (Var v) unf _ (Lit l) _ _= (Lit l) unf _ (Comb ConsCall c es) _ _= (Comb ConsCall c es) unf _ (Comb PartCall c es) _ _= (Comb PartCall c es) -- HNF: FunEval: unf pst (Comb FuncCall c (es:x)) prg nom= if c=="foldr" then fobu pst (Comb FuncCall c (unf_list pst (es:x) prg nom))nom else if proceedUnfold pst (Comb FuncCall c (es:x)) nom then peval_fun (incrDepth pst) c (es:x) else (Comb FuncCall c (es:x)) -- else if c=="dapp_build" then (Comb FuncCall c [(unf pst es prg)]) unf pst (Case ctype (Comb combtype f es) ces) _ nom= if combtype==FuncCall then if proceedUnfold pst (Comb combtype f es) nom then peval_casefun (incrDepth pst) ctype f es ces -- Case Fun else (Case ctype (Comb combtype f es) ces) -- stop unfolding else (Case ctype (Comb combtype f es) ces) unf _ (Case ctype (Var v) ces) _ _= (Case ctype (Var v) ces) unf _ (Case ctype (Case ct e cet) ces) _ _= (Case ctype (Case ct e cet) ces) unf pst (Apply x1 x2) prg nom = no_apply pst (Apply x1 x2) prg nom unf _ f _ _= f ---------------------------------------------------------------------------- ---------------------------------------------------------------------------- peval0 pst e = peval pst e peval_fun pst f es = newexp where (_,newexp) = matchRHS pst f es peval :: PEvalState -> Expr -> Expr -- HNF: peval _ (Var v) = (Var v) peval _ (Lit l) = (Lit l) peval _ (Comb ConsCall c es) = (Comb ConsCall c es) peval _ (Comb PartCall c es) = (Comb PartCall c es) peval _ (Comb FuncCall c es) = (Comb FuncCall c es) -- Case Fun + Case Select peval pst (Case ctype (Comb combtype f es) ces) = if combtype==FuncCall then (Case ctype (Comb combtype f es) ces) -- stop unfolding else peval0 pst (matchBranch ces f es) -- Case Select peval_casefun pst ctype f es ces = peval0 newpst (Case ctype newexp ces) where (newpst,newexp) = matchRHS pst f es -- Case static Guess: peval pst (Case ctype (Var v) ces) = Case ctype (Var v) (map (peval_branch pst) ces) -- Case Flat: peval pst (Case ctypej (Case ctypek e cesk) cesj) = peval0 pst (Case ctypek e (map (gen_subcase cesj) cesk)) where gen_subcase cesj (Pattern litk varsk ek) = Pattern litk varsk (Case ctypej ek cesj) peval _ f = f ---------------------------------------------------------------------------- ---------------------------------------------------------------------------- -- proceed partial evaluation of case branches: peval_branch pst (Pattern lit vs e) = Pattern lit vs (peval0 pst e) -- is f a defined function? definedFunc pst f = any (hasName f) (getFuncDecls pst) where hasName name (Func fname _ _ _) = fname==name -- match a branch (for Case Select): matchBranch [] _ _ = (Comb FuncCall "FAIL" []) matchBranch (Pattern (Ident p) vars e : ces) c es = if p==c then replace vars es 0 e else matchBranch ces c es -- match a right-hand side of a given function: matchRHS pst f es = getMatchedRHS pst (getFuncDecls pst) f es getMatchedRHS pst (Func fname _ _ funrule : fds) name es = if fname==name then getMatchedRHS_aux pst funrule es else getMatchedRHS pst fds name es getMatchedRHS_aux pst (Rule vars rhs) es = let curr_ri = getRenamingIndex pst maxindex = max (maxList vars) (maxVarIndex rhs) in (updateRenamingIndex pst (curr_ri+maxindex+1), replace vars es curr_ri rhs) replace :: [Int] -> [Expr] -> Int -> Expr -> Expr replace vs es b (Var v) = replaceVar vs es v where replaceVar [] [] var = Var (b+var) replaceVar (v:vs) (e:es) var = if v==var then e else replaceVar vs es var replace _ _ _ (Lit l) = Lit l replace vs es b (Comb combtype c exps) = Comb combtype c (map (replace vs es b) exps) replace vs es b (Apply e1 e2) = Apply (replace vs es b e1) (replace vs es b e2) replace vs es b (Constr vars e) = Constr (map (+b) vars) (replace vs es b e) replace vs es b (Or e1 e2) = Or (replace vs es b e1) (replace vs es b e2) replace vs es b (Case ctype e cases) = Case ctype (replace vs es b e) (map (replaceCase vs es b) cases) replace vs es b (GuardedExpr vars c e) = GuardedExpr (map (+b) vars) (replace vs es b c) (replace vs es b e) replace vs es b (Choice e) = Choice (replace vs es b e) replaceCase vs es b (Pattern l as e) = Pattern l (map (+b) as) (replace vs es b e) ------------------------------------------------------------------------------ -- handling variables in expressions: -- get the maximum index of all variables in an expression: -- (or -1 if there is no variable) maxVarIndex :: Expr -> Int maxVarIndex (Var v) = v maxVarIndex (Lit _) = -1 maxVarIndex (Comb _ _ exps) = maxList (map maxVarIndex exps) maxVarIndex (Apply e1 e2) = max (maxVarIndex e1) (maxVarIndex e2) maxVarIndex (Constr vars e) = max (maxList vars) (maxVarIndex e) maxVarIndex (Or e1 e2) = max (maxVarIndex e1) (maxVarIndex e2) maxVarIndex (Case _ e cs) = max (maxVarIndex e) (maxList (map maxCase cs)) where maxCase (Pattern _ as e) = max (maxList as) (maxVarIndex e) maxVarIndex (GuardedExpr vars c e) = max (max (maxList vars) (maxVarIndex c)) (maxVarIndex e) maxVarIndex (Choice e) = maxVarIndex e -- maximum of two numbers: max i j = if i<=j then j else i -- maximum of a list of naturals (-1 if list is empty): maxList xs = foldr max (-1) xs --------------------------------------------------------------------------- -- difference-lists transformations ---------------------------------------------------------------------------- -- Lanza la accion para todas las funciones del programas all_fun_diff (x:xs) p act nom = x1 ++ (all_fun_diff xs p act nom) where x1= first (change_Fun_diff x p act nom) all_fun_diff [] _ _ _= [] -- Para la funcion indicada realiza la accion hasta que no se pueda -- aplicar mas change_Fun_diff (Func x1 x2 x3 Rule1) p act nom= if Rule_new ==Rule1 then [(Func x1 x2 x3 Rule_new)] else ([(Func (x1++"w2") (x2+1) (first (act_type x3)) (act_par Rule_new))]++(New_Fun x1 x2 x3)) where Rule_new= change_Rule_diff Rule1 p act nom x1 change_Fun_diff x _ _ _= [x] change_Rule_diff (Rule x1 e) _ _ nom nom_fun = (Rule x1 e_new) where e_new= first (diffl e nom nom_fun) act_par (Rule x1 e) = (Rule (x1++[33]) e) act_type (FuncType a b) = (FuncType a (FuncType b b)) act_type f = f New_Fun x1 x2 x3 = [(Func x1 x2 x3 (Rule (Build_Arg x2) (Comb FuncCall (x1++"w2") x4)))] where x4=Build_rhs x2 Build_rhs x = if (x==0) then [(Comb ConsCall "[]" [])] else (Var (35+x):Build_rhs(x-1)) Build_Arg x = if (x==0) then [] else ((35+x):Build_Arg(x-1)) diffl (Case ctype (Var v) ces) nom nom_fun= (Case ctype (Var v) (case_trt ces nom nom_fun)) diffl f _ _= f case_trt x nom nom_fun= if (x==xe) then x else cambia_lis_vacia xe where xe=case_anal x nom nom_fun case_anal (x:xs) nom nom_fun= z:(case_anal xs nom nom_fun) where z=(first (branch_anal x nom nom_fun)) case_anal [] _ _=[] branch_anal (Pattern lit lis (Comb FuncCall c (es:x))) nom nom_fun= if (c==(nom++"_append")) then if (inorderr == orig) then if (postorderr == orig) then if (preorderr == orig) then orig else preorderr else postorderr else inorderr else orig where inorderr = (Pattern lit lis (first(inord (Comb FuncCall c (es:x)) nom_fun))) postorderr = (Pattern lit lis (first(postord (Comb FuncCall c (es:x)) nom_fun))) preorderr = (Pattern lit lis (first(preord (Comb FuncCall c (es:x)) nom_fun))) orig = (Pattern lit lis (Comb FuncCall c (es:x))) branch_anal (Pattern lit lis x) _ _ =(Pattern lit lis x) cambia_lis_vacia (x:xs)= z:(cambia_lis_vacia xs) where z=(first (branch_anal_va x)) cambia_lis_vacia [] = [] branch_anal_va (Pattern lit lis (Comb ConsCall d s))= if (d=="[]") then (Pattern lit lis (Var 33)) else (Pattern lit lis (Comb ConsCall d s)) branch_anal_va (Pattern lit lis x) =(Pattern lit lis x) ----------------------------------------------------------------------------- --PREORD preord (Comb FuncCall c (es:x)) nom_fun = if (res==True) then if (Comp_funs (head arg) (head(x)) nom_fun) then (Comb ConsCall ":" ([ar1]++[argtr])) else (Comb FuncCall c (es:x)) else (Comb FuncCall c (es:x)) where argtr = addarg (head arg) [(ChanNom (head x))] (res,ar1,arg)= escons es preord x _= x addarg (Comb FuncCall c args) x =(Comb FuncCall (c++"w2") (args ++x)) addVar x = x ++ [(Var 33)] escons(Comb ConsCall c (es:x))= if (c==":") then (True,es,x) else (False,es,x) ChanNom (Comb FuncCall c1 x1) =(Comb FuncCall (c1++"w2") (addVar x1)) Comp_funs a1 a2 nom_fun = if ((first(Nomfun a1)==first( Nomfun a2))&& (first(Nomfun a1)==nom_fun)) then True else False Nomfun (Comb FuncCall c1 _)= c1 Nomfun (Comb ConsCall c1 _)= c1 Nomfun _ = "" ----------------------------------------------------------------------------- -- POSTORD postord (Comb FuncCall c (es:x)) nom_fun= if (Comp_funs es argm nom_fun) then (Comb FuncCall (nom++"w2") ((head arg):[add_var (head x)])) else (Comb FuncCall c (es:x)) where argm= Ext_fun(head x) (nom,arg)=ext_nom_arg es postord x _= x Ext_fun (Comb FuncCall c (es:x)) = if (first (es_elem_lis (head x))==True) then es else (Comb FuncCall c (es:x)) es_elem_lis (Comb ConsCall c _)= if c==":" then True else False es_elem_lis (Comb FuncCall _ _ )= False es_elem_lis _ = False add_var (Comb FuncCall _ (es:x) )= (Comb FuncCall (nom++"w2") ((head arg):argf)) where argf =[add_var_lis (head x)] (nom,arg)=ext_nom_arg es add_var_lis (Comb ConsCall c (es:_)) = (Comb ConsCall c (es:[y])) where y=(Var 33) ext_nom_arg (Comb FuncCall a x )=(a,x) --------------------------------------------------------------------------- --INORDER inord (Comb FuncCall c (es:x)) nom_fun = if ((first (is_fun es))&& (Comp_funs es es nom_fun)&&(first (es_elem_lis (head x))))then (Comb FuncCall (nom++"w2") (args++[x1])) else (Comb FuncCall c (es:x)) where (nom,args)=ext_nom_arg es x1 = add_acc_cons (head x) -- inord x _= x add_acc_cons (Comb ConsCall c (es:x)) =(Comb ConsCall c (es:[x1])) where x1 = first (add_acc (head x)) add_acc (Comb FuncCall c (es:x))=(Comb FuncCall (c++"w2") (es:(x++[(Var 33)]))) add_acc (Comb ConsCall c x)= if c=="[]" then (Var 33) else (Comb ConsCall c x) --add_acc f = f is_fun (Comb FuncCall _ _) = True is_fun _ = False ------------------------------------------------------------------------------ -- pretty printer for case expressions: ppExpr _ (Var n) = ppVar n ppExpr _ (Lit l) = ppLit l ppExpr b (Comb _ cf es) = "(" ++ flatShowString cf ++ " " ++ ppList (ppExpr b) es ++ ")" ppExpr b (Apply e1 e2) = "(" ++ ppExpr b e1 ++ " " ++ ppExpr b e2 ++ ")" ppExpr b (Constr xs e) = "(Constr " ++ flatShowList ppVar xs ++ (ppExpr b) e ++ ")" ppExpr b (Or e1 e2) = "(Or " ++ ppExpr b e1 ++ " " ++ ppExpr b e2 ++ ")" ppExpr b (Case Rigid e cs) = "(Case " ++ ppExpr b e ++ " of\n " ++ ppList (ppCase (b+2)) cs ++ blanks b ++ ")" ppExpr b (Case Flex e cs) = "(FCase " ++ ppExpr b e ++ " of\n " ++ ppList (ppCase (b+2)) cs ++ blanks b ++ ")" ppExpr b (GuardedExpr xs e1 e2) = "(GuardedExpr " ++ flatShowList ppVar xs ++ ppExpr b e1 ++ " " ++ ppExpr b e2 ++ ")" ppExpr b (Choice e) = "(Choice " ++ ppExpr b e ++ ")" ppVar i = "v" ++ show i ppLit (Intc i) = show i ppLit (Floatc f) = show f ppLit (Charc c) = "'" ++ show (ord c) ++ "'" ppLit (Ident s) = flatShowString s ppCase b (Pattern l xs e) = blanks b ++ "(" ++ ppLit l ++ " " ++ ppList ppVar xs ++ " -> " ++ ppExpr b e ++ ")\n" ppList format elems = ppListElems format elems ppListElems _ [] = "" ppListElems format [x] = format x ppListElems format (x1:x2:xs) = format x1 ++ " " ++ ppListElems format (x2:xs) blanks b = if b==0 then "" else ' ':blanks (b-1) pprint p = ppRule p ppRule :: Prog -> IO () ppRule (Prog _ _ _ _ fds _)= ppRule_aux fds ppRule_aux :: [FuncDecl] -> IO () ppRule_aux [] = done ppRule_aux (Func fname _ _ (Rule lhsVars rhs) : fds) = putStr (flatShowString fname) >> putStr " " >> putStr (ppLhs lhsVars) >> putStr " = " >> putStrLn (ppExpr 0 rhs) >> ppRule_aux fds ppLhs :: [Int] -> String ppLhs [] = [] ppLhs (s : ss) = flatShowString ("v"++show s) ++ " " ++ ppLhs ss ------------------------------------------------------------------------------ -- auxiliaries: any :: (a -> Bool) -> [a] -> Bool any p l = foldr (||) False (map p l) -- delete all occurrences of an element in a list: deleteAll :: a -> [a] -> [a] deleteAll _ [] = [] deleteAll x (y:ys) = if x==y then deleteAll x ys else y : deleteAll x ys unzip :: [(a,b)] -> ([a],[b]) unzip [] = ([],[]) unzip ((x,y):zs) = (x:xs,y:ys) where (xs,ys) = unzip zs pprf2 :: Prog -> String -> IO () pprf2 prog name= unsafePrint (" Writing out "++name++".flat \n") (writeFile (name++(".flat")) (showFlatExtProg prog)) --pprf2 prog _= unsafePrint (" Writing out kk.flat \n") (writeFile ("kk.flat") (showFlatExtProg prog)) pprf name = readFlatCurry name >>= \prog -> --putStrLn (showFlatExtProg prog) unsafePrint (" Writing out "++name++"\n") (writeFile (name++".ffflat") (showFlatExtProg prog)) ppf name = readFlatCurry name >>= \prog -> --putStrLn (showFlatExtProg prog) unsafePrint (" Writing out "++name++"\n") (writeFile ("kk.flat") (showProg prog)) showFlatExtProg :: Prog -> String showFlatExtProg (Prog modname _ types _ funcs table) = "prog(" ++ flatExtShowString modname ++ "," ++ "datadecl(" ++ flatExtShowList flatExtShowType types ++ ")," ++ "funcdecl(" ++ flatExtShowList flatExtShowFunc funcs ++ ")," ++ "translation(" ++ flatExtShowList flatExtShowTrans table ++"))." flatExtShowType (Type name tpars consdecls) = "type(" ++ flatExtShowString name ++ "," ++ flatExtShowList flatExtShowTypeVar tpars ++ "," ++ flatExtShowList flatExtShowCons consdecls ++ ")" flatExtShowTypeVar tpar = "tvar(" ++ flatExtShowVar tpar ++ ")" flatExtShowCons (Cons cname arity types) = "cons(" ++ flatExtShowString cname ++ "," ++ show arity ++ "," ++ flatExtShowList flatExtShowTypeExpr types ++ ")" flatExtShowFunc (Func name arity ftype rl) | isChoice rl = "choicefunc(" ++ flatExtShowString name ++ "," ++ show arity ++ "," ++ flatExtShowList flatExtShowTypeExpr (flattenFuncType ftype) ++ "," ++ flatExtShowRule name (strip rl) ++ ")" | otherwise = "func(" ++ flatExtShowString name ++ "," ++ show arity ++ "," ++ flatExtShowList flatExtShowTypeExpr (flattenFuncType ftype) ++ "," ++ flatExtShowRule name rl ++ ")" where isChoice (External _) = False isChoice (Rule _ (Var _)) = False isChoice (Rule _ (Lit _)) = False isChoice (Rule _ (Comb _ _ _)) = False isChoice (Rule _ (Apply _ _)) = False isChoice (Rule _ (Constr _ _)) = False isChoice (Rule _ (Or _ _)) = False isChoice (Rule _ (Case _ _ _)) = False isChoice (Rule _ (GuardedExpr _ _ _)) = False isChoice (Rule _ (Choice _)) = True strip (Rule params (Choice e)) = Rule params e -- flatten the function type. nested function types remain (stupid .flat format...) flattenFuncType (FuncType t1 t2) = t1:flattenFuncType t2 flattenFuncType (TCons tc ts) = [TCons tc ts] flattenFuncType (TVar n) = [TVar n] flatExtShowRule func (Rule params expr) = "rule(" ++ flatExtShowString func ++ (if length(params)>0 then "(" ++ flatExtShowListElems flatExtShowVar params ++ ")" else -- write func instead of func() "") ++ "," ++ flatExtShowExpr expr ++")" flatExtShowRule _ (External name) = "external(" ++ flatExtShowString name ++ ")" flatExtShowTypeExpr (FuncType t1 t2) = "functype(" ++ flatExtShowTypeExpr t1 ++ "," ++ flatExtShowTypeExpr t2 ++ ")" flatExtShowTypeExpr (TCons tc ts) = "tcons(" ++ flatExtTransTCons tc ++ "," ++ flatExtShowList flatExtShowTypeExpr ts ++ ")" where flatExtTransTCons ttc | ttc == "[]" = "list" | otherwise = flatExtShowString ttc flatExtShowTypeExpr (TVar n) = flatExtShowTypeVar n flatExtShowExpr (Var n) = "var(" ++ flatExtShowVar n ++ ")" flatExtShowExpr (Lit l) = flatExtShowLit l flatExtShowExpr (Comb _ cf es) = "comb(" ++ flatExtShowString cf ++ "," ++ flatExtShowList flatExtShowExpr es ++ ")" flatExtShowExpr (Apply e1 e2) = "apply(" ++ flatExtShowExpr e1 ++ "," ++ flatExtShowExpr e2 ++ ")" flatExtShowExpr (Constr xs e) = "constr(" ++ flatExtShowList flatExtShowVar xs ++ "," ++ flatExtShowExpr e ++ ")" flatExtShowExpr (Or e1 e2) = "or(" ++ flatExtShowExpr e1 ++ "," ++ flatExtShowExpr e2 ++ ")" flatExtShowExpr (Case Rigid e cs) = "case(" ++ flatExtShowExpr e ++ "," ++ flatExtShowList flatExtShowCase cs ++ ")" flatExtShowExpr (Case Flex e cs) = "f" ++ flatExtShowExpr (Case Rigid e cs) flatExtShowExpr (GuardedExpr xs e1 e2) = "guardedexpr(" ++ flatExtShowList flatExtShowVar xs ++ "," ++ flatExtShowExpr e1 ++ "," ++ flatExtShowExpr e2 ++ ")" flatExtShowExpr (Choice e) = "choicefunc(" ++ flatExtShowExpr e ++ ")" flatExtShowLit (Intc i) = "int(" ++ show i ++ ")" flatExtShowLit (Floatc f) = "float(" ++ show f ++ ")" flatExtShowLit (Charc c) = "char(" ++ show (ord c) ++ ")" flatExtShowLit (Ident s) = flatExtShowString s flatExtShowCase (Pattern l xs e) = "pattern(" ++ flatExtShowPatLit l ++ "," ++ flatExtShowList flatExtShowVar xs ++ "," ++ flatExtShowExpr e ++ ")" where flatExtShowPatLit (Intc i) = show i flatExtShowPatLit (Floatc f) = show f flatExtShowPatLit (Charc c) = show (ord c) flatExtShowPatLit (Ident s) = flatExtShowString s flatExtShowTrans (Trans n intn) = "trans("++ flatExtShowString n ++ "," ++ flatExtShowString intn ++")" -- format a finite list of elements: flatExtShowList format elems = "[" ++ flatExtShowListElems format elems ++ "]" flatExtShowListElems _ [] = "" flatExtShowListElems format [x] = format x flatExtShowListElems format (x1:x2:xs) = format x1 ++ "," ++ flatExtShowListElems format (x2:xs) -- format a string: -- retransform some of the FlatCurry syntax into .flat-syntax flatExtShowString s | s == "Int" = "int" | s == "Float" = "float" | s == "Bool" = "bool" | s == "Char" = "char" | s == "IO" = "io" | s == "Constraint" = "constraint" | s == ":" = "'.'" | s == "." = "'$comp'" | s == "&" = "/\\" | s == "=:=" = "=" | s == "success" = "'{}'" | s == "[]" = "[]" | otherwise = "'" ++ s ++ "'" -- | s == "()" = "unit" -- | s == "(,)" = "pair" -- format a variable name flatExtShowVar var = "_" ++ (show var) -- end of program -- end of program -- end of program