cfunction cwriteF :: ( string , string ) -> string; cfunction cappendF :: ( string , string ) -> string; cfunction creadF :: ( string ) -> string; cfunction cabort :: ( string ) -> string; cfunction traceThis :: ( string ) -> int; trace m x = if ((traceThis m)=0) x x; bot = bot ; abort x = case cabort x of Nil -> bot; buildInConstr = ["True","False","Nil","Cons","Pair"]; data Bool = True|False; if cond a1 a2 = case cond of True -> a1;False->a2; and x y = case x of False -> (False); True -> y; or x y = case x of True -> (True); False -> y; not x = case x of True -> (False); False -> (True); data List a = Nil|Cons a (List a); head xs = case xs of Cons y ys -> y; tail xs = case xs of Cons y ys -> ys; isEmpty xs = case xs of Nil ->(True);Cons y ys-> (False); last xs = case xs of Cons y ys -> (case ys of Cons z zs -> last ys; Nil -> y); add x y = x+y; length xs = case xs of Nil -> 0;Cons y ys-> add 1 (length ys); append xs ys = case xs of Nil -> ys; Cons z zs -> (Cons z (append zs ys)); concat xss = case xss of Nil -> []; Cons ys yss -> append ys (concat yss); aborts xs = case cabort (concat xs) of Nil -> bot; reverse xs = case xs of Nil ->[]; Cons y ys -> append (reverse ys) [y]; contains comp x xs = case xs of Nil -> False; Cons y ys -> (case (comp x y) of True -> True; False -> contains comp x ys); drop n xs = case (n = 0) of True -> xs; False -> (case xs of Nil -> []; Cons y ys -> drop (n-1) ys); from n = (Cons n (from (n+1))); listMap f xs = case xs of Nil ->[]; Cons y ys->(Cons (f y) (listMap f ys)); data Pair a b = Pair a b; data Box a = Box a; data Tuple3 a b c = Tuple3 a b c; data Tuple4 a b c d = Tuple4 a b c d; data Tuple5 a b c d e = Tuple5 a b c d e; data Tuple6 a b c d e f = Tuple6 a b c d e f; fst p = case p of Pair e1 e2 -> e1; snd p = case p of Pair e1 e2 -> e2; fst3 p = case p of Tuple3 e1 e2 e3 -> e1; snd3 p = case p of Tuple3 e1 e2 e3 -> e2; thrd3 p = case p of Tuple3 e1 e2 e3 -> e3; stringEq xs ys = case xs of Nil -> (case ys of Nil -> (True); Cons y1 ys1 -> (False)); Cons x1 xs1 -> (case ys of Nil -> (False); Cons y1 ys1 -> and (y1=x1) (stringEq xs1 ys1)); containsStr x xs = contains stringEq x xs; lookUp x ps = case ps of Cons p ys -> (case p of Pair key value -> (case (stringEq key x) of True -> value; False-> lookUp x ys)); Nil -> abort (append (append ("not in environment: ") x) ("!")); zip xs ys = case xs of Nil -> []; Cons x1 xs1 ->(case ys of Nil -> []; Cons y1 ys1 -> (Cons (Pair x1 y1)(zip xs1 ys1)) ); getPosition i str xs = case xs of Cons y ys -> (case (stringEq str y) of True -> i; False-> getPosition (i+1) str ys); data Either a b = Left a|Right b; getLeftRight lr = case lr of Left l -> l; Right r -> r; data ParsResult res tok = ParsResult res tok |Fail tok; parsCharToken tok xs = case xs of Nil -> (Fail xs); Cons y ys -> if (y = tok) (ParsResult y ys)(Fail xs); parsStringToken tok xs = case xs of Nil -> (Fail xs); Cons y ys -> if (stringEq y tok)(ParsResult y ys)(Fail xs); getToken xs = case xs of Nil -> (Fail xs);Cons y ys ->(ParsResult y ys); seq p1 p2 xs = case (p1 xs) of Fail ys -> (Fail xs); ParsResult res further -> (case (p2 further) of Fail zs -> (Fail xs); ParsResult res2 fs2 -> (ParsResult (res,res2) fs2)); alt p1 p2 xs = case (p1 xs) of Fail ys -> (case (p2 xs) of Fail zs -> (Fail xs); ParsResult l fs1 -> (ParsResult (Right l) fs1)); ParsResult res further -> (ParsResult (Left res) further); ualt p1 p2 xs = case (p1 xs) of Fail ys -> (case (p2 xs) of Fail zs -> (Fail xs); ParsResult l fs1 -> (ParsResult l fs1)); ParsResult res further -> (ParsResult res further); map f p xs = case (p xs) of Fail ys -> (Fail xs); ParsResult res further -> (ParsResult (f res) further); rep0 p1 xs = case (p1 xs) of Fail fs1 -> (ParsResult [] xs); ParsResult res fs2 -> (case (rep0 p1 fs2) of ParsResult res2 fs3 -> (ParsResult (Cons res res2) fs3)); consPair pa = case pa of Pair x xs ->(Cons x xs); rep1 p1 xs = map consPair (seq p1 (rep0 p1)) xs; return x xs = (ParsResult x xs); sepBy p sep xs=map consPair (seq p (rep0 (map snd (seq sep p)))) xs; sepBy0 p sep xs= ualt (sepBy p sep) (return []) xs; check cond p xs = case xs of Cons y ys -> if (cond y) (p xs) (Fail xs); Nil -> Fail xs; pString str xs = case str of Nil -> (ParsResult str xs); Cons s tr -> (case (parsCharToken s xs) of Fail f -> (Fail xs); ParsResult c further -> (case (pString tr further) of Fail f2 -> (Fail xs); ParsResult cs further2 -> (ParsResult (Cons c cs) further2))); dropline xs = case xs of Nil -> xs; Cons y ys -> (if (y='\n') (removeComments xs) (dropline ys)); removeComments xs = case xs of Nil -> xs; Cons x1 xs1 -> (case xs1 of Nil -> xs; Cons x2 xs2 -> if (and (x1=('-')) (x2=('-')) ) (dropline xs2) (Cons x1 (removeComments xs1))); whiteChars = (" \n\t"); oneOfTheseChars str xs = case str of Cons s tr -> (case tr of Nil -> parsCharToken s xs; Cons t r -> ualt (parsCharToken s) (oneOfTheseChars tr) xs); whiteChar xs = oneOfTheseChars whiteChars xs; whiteSpace xs = rep0 whiteChar xs; deleteWhite p xs = map snd (seq whiteSpace p) xs; data Fab4 a = Fab4 a (List (Def a)) (List (Def a)) (List (Def a)) (List (Def a)); data Def a= ConstrDef (List (Char)) (Int) |FunDef a (List (Char)) (List (List (Char))) (Expr a) |CFunDef a (List (Char)) (List (List (Char))) (List (Char)) |DataTypeDef (List (Char)) (List (List (Char))) (List (DataTypeAlt)); data DataTypeAlt = DataTypeAlt (List (Char)) (List (Type)); data Type = TypeVar (List (Char)) | FunType (Type) (Type) | AlgType (List (Char)) (List (Type)); showType t = case (t) of TypeVar name -> name; FunType t1 t2 -> concat ["(",showType t1, " -> ",showType t2,")"]; AlgType name types -> concat ["(",name, concat (listMap spaceShow types),")"]; spaceShow t = append " " (showType t); data Expr a = VarExpr a (List (Char)) |ConstructorCall a (List (Char)) (List (Expr a)) |NumExpr a (Int) |CharExpr a (Char) |AppExpr a (Expr a) (Expr a) |CaseExpr a (Expr a) (List (CaseAlt a)) |OpExpr a (Expr a) (List (Char)) (Expr a) ; data CaseAlt a = CaseAlt a (List (Char)) (List (List (Char))) (Expr a); nilName = ("Nil"); consName = ("Cons"); keywords = ([ "constr", "case", "of","cfunction","data"]); constrP xs = deleteWhite (pString ("constr")) xs; dataP xs = deleteWhite (pString ("data")) xs; caseP xs = deleteWhite (pString ("case")) xs; ofP xs = deleteWhite (pString ("of")) xs; cfunctionP xs= deleteWhite (pString ("cfunction")) xs; arrowP xs = deleteWhite (pString ("->")) xs; semicolonP xs= deleteWhite (pString (";")) xs; coloncolonP xs = deleteWhite (pString ("::")) xs; commaP xs = deleteWhite (pString (",")) xs; lparP xs = deleteWhite (pString ("(")) xs; rparP xs = deleteWhite (pString (")")) xs; lbraP xs = deleteWhite (pString ("[")) xs; rbraP xs = deleteWhite (pString ("]")) xs; barP xs = deleteWhite (pString ("|")) xs; addP xs = deleteWhite (pString ("+")) xs; subP xs = deleteWhite (pString ("-")) xs; multP xs = deleteWhite (pString ("*")) xs; divP xs = deleteWhite (pString ("/")) xs; leP xs = deleteWhite (pString ("<=")) xs; geP xs = deleteWhite (pString (">=")) xs; ltP xs = deleteWhite (pString ("<")) xs; gtP xs = deleteWhite (pString (">")) xs; eqP xs = deleteWhite (pString ("=")) xs; cNameP xs = deleteWhite (map consPair (seq upperCaseLetterP (rep0 symbolP))) xs; nameP xs = case (deleteWhite (map consPair (seq lowerCaseLetterP (rep0 symbolP))) xs) of Fail f -> Fail xs; ParsResult y ys -> if (containsStr y keywords)(Fail xs)(ParsResult y ys); identP xs = deleteWhite (map consPair (seq letterP (rep0 symbolP))) xs; numberP xs = map mkNum (deleteWhite (rep1 digitP)) xs; mkNum x = (NumExpr True (toNum x)); toNum xs = toNumAux 0 xs; toNumAux n xs = case xs of Nil -> n; Cons c cs -> toNumAux (n*10 +(c+0-48)) cs; upperCaseLetterP xs=oneOfTheseChars("ABCDEFGHIJKLMNOPQRSTUVWXYZ")xs; lowerCaseLetterP xs=oneOfTheseChars("abcdefghijklmnopqrstuvwxyz")xs; letterP xs =ualt upperCaseLetterP lowerCaseLetterP xs; digitP xs =oneOfTheseChars ("0123456789") xs; symbolP xs =ualt digitP letterP xs; stringLiteralP xs = map mkStringLiteral stringLitP xs; mkStringLiteral str = case str of Nil -> ConstructorCall True nilName []; Cons c cs -> ConstructorCall True consName [CharExpr True c,mkStringLiteral cs]; stringLitP xs = case (deleteWhite (pString ("\"")) xs) of Fail f -> (Fail xs); ParsResult c cs -> (case (getStringLit cs) of Fail f2 -> (Fail xs); ParsResult str further ->(ParsResult str further)); getStringLit xs = case (getToken xs) of Fail rest -> (Fail xs); ParsResult y ys -> (case (y = (head ("\\"))) of True -> (case (getEscapeChar ys) of Fail f ->(Fail xs); ParsResult c cs -> (ParsResult c cs) ); False-> (case (y=(head ("\""))) of True -> (ParsResult [] ys); False-> getFurtherChars y ys xs)); getFurtherChars c cs xs = case (getStringLit cs) of Fail rest -> (Fail xs); ParsResult y ys -> (ParsResult (Cons c y) ys); getEscapeChar xs = case (getEscape xs) of Fail ys -> (Fail xs); ParsResult c cs -> getFurtherChars c cs xs; charLiteralP xs = case (deleteWhite (pString ("'")) xs) of Fail f -> (Fail xs); ParsResult c1 cs1 -> (case (getCharLit cs1) of Fail f2 -> (Fail xs); ParsResult c2 cs2 -> (case (pString ("'") cs2) of Fail f3 ->(Fail xs); ParsResult c3 cs3 -> (ParsResult (CharExpr True c2) cs3))); getEscape xs = case (getToken xs) of Fail ys -> (Fail xs); ParsResult c cs -> if (c=('n')) (ParsResult (head ("\n")) cs) (if (c=('t')) (ParsResult (head ("\t")) cs) (if (c=(head("\""))) (ParsResult (head ("\"")) cs) (if (c=(head("\\"))) (ParsResult (head ("\\")) cs) (Fail xs)))); getCharLit xs = case (getToken xs) of Fail f -> (Fail xs); ParsResult c1 cs1 -> if (c1=(head ("\\")))(getEscape cs1)(ParsResult c1 cs1); listLiteralP xs = map mkListLiteral (map snd (seq (deleteWhite lbraP) (map fst (seq (sepBy0 exprP commaP) rbraP) ))) xs; mkListLiteral xs = case xs of Nil -> (ConstructorCall True nilName [] ); Cons y ys -> ConstructorCall True consName [y,mkListLiteral ys]; fab4P xs = map mkFab4 (sepBy (ualt funDefP (ualt constrDefP (ualt cFunDefP dataTypeDefP))) semicolonP) (removeComments xs); dataTypeDefP xs = map snd (seq dataP (map mkDataTypeDef (seq (seq cNameP varsP) (map snd (seq eqP (sepBy dataTypeAltP barP)))))) xs; dataTypeAltP xs = map mkDataTypeAlt (seq cNameP (rep0 atomTypeP)) xs; mkDataTypeAlt p = DataTypeAlt (fst ( p))(snd p); atomTypeP xs = ualt parTypeP (ualt algTypeP typeVarP) xs; parTypeP xs = map snd (seq lparP (map fst (seq funTypeP rparP))) xs; funTypeP xs = seq atomTypeP funType2P xs; funType2P xs = ualt (map mkFunType2 (seq arrowP funTypeP))(return id) xs; mkFunType2 p = funTypeToThis (snd p); funTypeToThis t2 t1 = FunType t1 t2; typeVarP xs = map mkTypeVar nameP xs; mkTypeVar v = (TypeVar v); algTypeP xs = map snd (seq lparP (map fst (seq (map mkAlgType (seq cNameP (rep0 atomTypeP))) rparP))) xs; mkAlgType p = AlgType (fst p) (snd p); mkDataTypeDef pNameVarspDefs = case pNameVarspDefs of Pair pNameVars defs -> (case pNameVars of Pair name vars -> DataTypeDef name vars defs); mkFab4 xs = case xs of Nil -> Fab4 True [][][][]; Cons y ys -> (case (mkFab4 ys) of Fab4 a cons funs cFuns dataDef-> (case y of FunDef a2 name args code -> Fab4 True cons (Cons y funs) cFuns dataDef; CFunDef a2 name args code -> Fab4 True cons funs (Cons y cFuns) dataDef; ConstrDef n i -> abort "'constr' is no longer supported. use 'data' instead!"; DataTypeDef n vs alts -> Fab4 True cons funs cFuns (Cons y dataDef) ) ); cFunDefP xs = map mkCFun (map snd (seq cfunctionP (seq (map fst (seq identP coloncolonP)) (seq cArgTypesP (map snd (seq arrowP identP)))))) xs; mkCFun p = case p of Pair name signature -> (case signature of Pair args result -> (CFunDef True name args result)); cArgTypesP xs = map snd (seq lparP (map fst (seq (sepBy identP commaP) rparP))) xs; constrDefP xs = map mkConstr (map snd (seq constrP (seq cNameP numberP))) xs; mkConstr p = case p of Pair n i -> ConstrDef n i; funDefP xs = map mkFun (seq nameP (seq varsP (map snd (seq eqP exprP)))) xs; mkFun p = case p of Pair n varex -> (case varex of Pair var ex->FunDef True n var ex); varsP xs = rep0 nameP xs; exprP xs = ualt constructorCallP (ualt caseExprP funCallP) xs; allowedNext = "\t\n ([\"'"; eq x y = x=y; newTok x = contains eq x allowedNext; seperated p xs = check newTok p xs; constructorCallP xs = map mkConstructorCall (seq cNameP (rep0 atomExprP)) xs; mkConstructorCall p = case p of Pair n args -> (ConstructorCall True n args); caseExprP xs = map mkCaseExpr (map snd (seq caseP (seq (seperated exprP) (map snd (seq ofP caseAltsP))))) xs; mkCaseExpr p = case p of Pair expr alts -> CaseExpr True expr alts; caseAltsP xs = sepBy caseAltP semicolonP xs; caseAltP xs = map mkCaseAlt (seq cNameP (seq varsP (map snd (seq arrowP exprP)))) xs; mkCaseAlt p = case p of Pair c argsAlt -> (case argsAlt of Pair as e -> (CaseAlt True c as e)); atomExprP xs = ualt numberP (ualt charLiteralP (ualt stringLiteralP (ualt listLiteralP (ualt (map mkConstr0 cNameP) (ualt (map mkVar nameP) lparExprP))))) xs; mkVar x = VarExpr True x; mkConstr0 x = ConstructorCall True x []; lparExprP xs = map snd (seq lparP (map apply2 (seq exprP (ualt parExprP tupleExprP)))) xs; apply2 p = (snd p)(fst p); parExprP xs = map fst (seq (return id) rparP) xs; returnId p = id; id x = x; tupleExprP xs = map fst (seq (map forTuple (rep0 (seq commaP exprP))) rparP) xs; forTuple xs = case listMap snd xs of Cons y ys -> (case ys of Nil -> pairWithThis y; Cons z zs -> tupleWithThis (Cons y ys)); pairWithThis y x = ConstructorCall True "Pair" [x,y]; tupleWithThis xs x = ConstructorCall True (append "Tuple" (showInt (length xs))) (Cons x xs); funCallP xs = map mkFunCall (rep1 compExprP) xs; mkFunCall xs = case xs of Cons y ys -> mkFunCall2 y ys; mkFunCall2 x xs = case xs of Nil -> x; Cons y ys -> mkFunCall2 (AppExpr True x y) ys; compExprP xs = map mkOp (seq addExprP (rep0 (seq compOpP addExprP))) xs; addExprP xs = map mkOp (seq multExprP (rep0 (seq addOpP multExprP))) xs; multExprP xs = map mkOp (seq atomExprP (rep0 (seq multOpP atomExprP))) xs; mkOp p = case p of Pair e1 opes -> mkOpsAux e1 opes; mkOpsAux e1 ps = case ps of Nil -> e1; Cons p ys ->(case p of Pair o e2 -> mkOpsAux (OpExpr True e1 o e2) ys); compOpP xs = ualt eqP (ualt leP (ualt geP (ualt ltP gtP))) xs; addOpP xs = ualt addP subP xs; multOpP xs = ualt multP divP xs; sNOP = ("NOP"); sPOP = ("POP"); sEND = ("END"); sJUMP = ("JUMP"); sPUSH = ("PUSH"); sUNWIND = ("UNWIND"); sEVAL = ("EVAL"); sPRINT = ("PRINT"); sPRINTSTRING = ("PRINTSTRING"); sOUTPUT = ("OUTPUT"); sMKAP = ("MKAP"); sJAVACALL = ("JAVACALL"); sPUSHGLOBAL = ("PUSHGLOBAL"); sPUSHINT = ("PUSHINT"); sPUSHCHAR = ("PUSHCHAR"); sSLIDE = ("SLIDE"); sUPDATE = ("UPDATE"); sPACK = ("PACK"); sCASEJUMP = ("CASEJUMP"); sSPLIT = ("SPLIT"); sADD = ("ADD"); sSUB = ("SUB"); sMULT = ("MULT"); sDIV = ("DIV"); sLE = ("LE"); sGE = ("GE"); sLT = ("LT"); sGT = ("GT"); sEQ = ("EQ"); sSTATICJAVACALL=("STATICJAVACALL") ; sGETRUNTIME = ("GETRUNTIME"); sCCALL = ("CCALL"); progArgsType = ("getProgArgs",AlgType "List" [AlgType "List" [AlgType "Int" []]]); genCCode fn pa = case pa of Fail f -> abort (append ("parse error: ") f); ParsResult fab4 rest -> if (isEmpty rest) (case (inferTypes (listMap addV (from 1)) fab4) of Fab4 a d1 d2 d3 d4 -> (case writeInterfaceFile (append fn ".fab4i")(Fab4 a d1 d2 d3 d4) of Cons v vs -> trace "start GenCode" (genCFab4Code (append fn ".c") (Fab4 a d1 d2 d3 d4)))) (abort (append ("parse error: could not parse: ") rest)); addV n = Cons 'v' (showInt n); genCFab4Code w fab4 = case fab4 of Fab4 a constrs functions cfuns dataDefs -> genCFab4Code2 w (append buildInConstr (append (listMap getConstrName constrs) (concat (listMap getConstrdataName dataDefs)) )) (listMap getFunctionName functions) (listMap getCFunctionName cfuns) cfuns functions; getConstrdataName c = case c of DataTypeDef n vs cs -> listMap getConstrAlgName cs; getConstrAlgName c = case c of DataTypeAlt n xs -> n; getConstrName c = case c of ConstrDef n i -> n; getFunctionName f = case f of FunDef a n v e -> n; getCFunctionName f = case f of CFunDef a n args reult -> n; genCFab4Code2 w conNames funNames cFunNames cfuns functions = writeCFab4Code w conNames cfuns functions (zip functions (listMap (genCFunctionCode conNames cFunNames funNames) (functions))); writeCFab4Code w conNames cfuns functions is = ( cappendF (writeCCode ( cappendF ( cappendF ( cappendF (writeFunctionInitTable ( cappendF (writeGlobals 0 (writeCCallCodes (cappendF (writeCConstructors (cwriteF w (append ("#include \"constants.h\"\n#include \"gm.h\"\n") (append ("#include \"ccall.h\"\n#include \n\n") ("int i;\n\n char* constructors [] = \n {")))) conNames) ("\n")) cfuns) functions cfuns) ("\n\nvoid init(){\n")) 5 is cfuns) ("\n i=")) (showInt ((length functions)+(length cfuns)))) (append (";\n numberOfGlobals=&i;") (append ("\n}\n\n int code [] =\n {PUSHGLOBAL\n ,") ("FUNCTION_INDEX_main\n ,EVAL\n ,PRINT\n ,END")))) is cfuns) (append (" };\n\nint main(int argc,char** argv){\n progArgsV=argv;\n progArgsC=argc;\n initGM();") ("\n init();\n eval();\n return(0);\n}\n"))); writeGlobals i w functions cfuns = case functions of Nil -> writeCGlobals i w cfuns ; Cons f funs -> writeGlobals (i+3) (writeGlobal i w f) funs cfuns; writeCGlobals i w cfuns = case cfuns of Nil -> w; Cons f funs -> writeCGlobals (i+3) (writeGlobal i w f) funs; writeGlobal i w f = case f of FunDef a name args code -> ( cappendF ( cappendF w (append (append ("\n#define FUNCTION_INDEX_") name) (" "))) (showInt i)); CFunDef a name args result -> ( cappendF ( cappendF w (append (append ("\n#define FUNCTION_INDEX_") name) (" "))) (showInt i)); writeCCallCodes w cfuns = case cfuns of Nil -> w; Cons f funs -> writeCCallCodes (writeCCallCode w f) funs; writeCCallCode w f = case f of CFunDef a name args result -> ( cappendF ( cappendF ( cappendF ( cappendF (argXiList 1 ( cappendF ( cappendF ( cappendF ( cappendF (cCallArgs 1 ( cappendF ( cappendF ( cappendF w ("\nvoid cfunction_")) name) ("(){")) args) result) (" result=0;\n result = ")) name) ("(")) ( length args)) (",result);\n ")) (getCPusherForType result)) ("(result);")) ("\n}\n\n")); argXiList i w end = if (i > end) w (argXiList (i+1) ( cappendF (if (i=1) ( cappendF w ("x")) ( cappendF w (",x"))) (showInt i)) end); cCallArgs i w args = case args of Nil -> w; Cons a rgs -> ( cappendF (cCallArgs (i+1) ( cappendF ( cappendF ( cappendF ( cappendF ( cappendF ( cappendF ( cappendF ( cappendF ( cappendF w ("\n ")) a) (" x")) (showInt i)) (";\n x")) (showInt i)) (" = ")) (getCGetterForType a i)) (";")) rgs) ("\n ")); getCGetterForType t i = if (stringEq t ("int")) ("getInt()") (if (stringEq t ("string")) ("getString()") ("getString()")); getCPusherForType t = if (stringEq t ("int")) ("pushCInt") (if (stringEq t ("string")) ("pushCString") ("pushCString")); writeFunctionInitTable w n funs cfuns = case funs of Nil -> writeCFunctionInitTable w n cfuns; Cons f funs2 -> (case f of Pair fDef is -> (case fDef of FunDef a name args code -> writeFunctionInitTable ( cappendF ( cappendF ( cappendF ( cappendF ( cappendF w ("\n nglb(")) (showInt (length args))) (",")) (showInt n)) (");")) (n+(calcSize is)) funs2 cfuns)); writeCFunctionInitTable w n cfuns = case cfuns of Nil -> w; Cons cf cfuns2 -> (case cf of CFunDef a name args result -> writeCFunctionInitTable ( cappendF ( cappendF ( cappendF ( cappendF ( cappendF w ("\n nglb(")) (showInt (length args))) (",")) (showInt n)) (");")) (n+3) cfuns2 ); writeCConstructors w cs = case cs of Nil -> w; Cons c cs1 -> (case cs1 of Nil -> cappendF ( cappendF ( cappendF w ("\"")) c) ("\"};\n\n\n"); Cons c1 cs2 ->writeCConstructors ( cappendF ( cappendF ( cappendF w ("\"")) c) ("\"\n ,")) cs1 ); genCFunctionCode conNames cfunNames funNames fun = case fun of FunDef a n as e -> removeUnused (False) (addFunEndCode (length as) (genExprCode funNames cfunNames conNames (mkEnv 0 as) e)); writeCCode w funs cfuns = case (concat (listMap snd funs)) of Cons c ode -> writeCIs w (Cons c ode) cfuns; Nil ->w; writeCFunsCCode w cfuns = case cfuns of Nil -> w; Cons cfun cfuns2 -> (case cfun of CFunDef a name args result -> writeCFunsCCode ( cappendF ( cappendF ( cappendF ( cappendF w ("\n ,CCALL")) (",(int)cfunction_")) name) ("\n ,UNWIND")) cfuns2); addFunEndCode n cs = if (n>0) (reverse (Cons (Unwind) (Cons (Pop n) (Cons (Update n) cs)))) (reverse (Cons (Unwind) cs)) ; mkEnv i as = case as of Nil -> []; Cons a ys -> (Cons (a, i) (mkEnv (i+1) ys)); getRuntimeCode = [GetRuntime]; genExprCode functions cfunNames constructors env expr = case expr of VarExpr a v-> if (stringEq v ("getProgArgs")) getRuntimeCode (if (contains stringEq v cfunNames) [PushGlobal v] (if (contains stringEq v functions) [PushGlobal v] [Push (lookUp v env)])); NumExpr a n -> [PushInt n]; CharExpr a c-> [PushChar c]; OpExpr a e1 op e2-> (Cons (getOpInstruction op) (append (Cons (Eval) (genExprCode functions cfunNames constructors (listMap addOneToSnd env) e1)) (Cons (Eval)(genExprCode functions cfunNames constructors env e2)))); ConstructorCall a c args-> (Cons (Pack (getPosition 0 c constructors) (length args)) (genConstrCallArgs functions cfunNames constructors env (reverse args))); AppExpr a e1 e2 -> (Cons (MkAp) (append (genExprCode functions cfunNames constructors (listMap addOneToSnd env) e1) (genExprCode functions cfunNames constructors env e2))); CaseExpr a e alts -> ( case((listMap (genAltCode functions cfunNames constructors env) alts)) of Cons cs css -> (case (reverse (genCaseAltsCode ((length alts)*2 +2) ((length alts)*2 +2) (calcSize (concat (listMap snd (Cons cs css)))) (Cons cs css))) of Cons pis iss -> append (concat (listMap snd (Cons pis iss))) (Cons (CaseJump (listMap fst (Cons pis iss))) (Cons (Eval) (genExprCode functions cfunNames constructors env e) )) ) ); genCaseAltsCode initialOfset start total alts = case alts of Nil -> []; Cons na alts2 -> (case na of Pair n a -> (case a of Cons jump is -> (Cons ( (n, start), (Cons (Jump (initialOfset+(total-start)-(calcSize a)+2)) is)) (genCaseAltsCode initialOfset (start+(calcSize a)) total alts2) )) ); genAltCode functions cfunNames constructors env caseAlt = case caseAlt of CaseAlt a n vars e -> (getPosition 0 n constructors , (Cons (Jump (0-1)) (Cons (Slide (length vars)) (reverse (removeUnused (False) (reverse (append (genExprCode functions cfunNames constructors (append (zip vars (from 0)) (listMap (addNToSnd (length vars)) env)) e) [Split (length vars)]))))))) ; genConstrCallArgs functions cfunNames constructors env args = case args of Nil -> []; Cons arg further -> (append (genConstrCallArgs functions cfunNames constructors (listMap addOneToSnd env) further) (genExprCode functions cfunNames constructors env arg) ); addOneToSnd p = addNToSnd 1 p; addNToSnd n p = case p of Pair e1 e2 ->( e1, (e2+n)); opInstructions = [("+", Add),("-", Sub),("*", Mult),("/", Div),( "<", Lt) ,(">", Gt) ,("<=", Le),(">=", Ge) ,("=", Eq)]; getOpInstruction op = lookUp op opInstructions; data Instruction = Nop |End |Jump (Int) |Unwind |Eval |Print |PrintString |Output (List (Char)) |MkAp |Add |Sub |Mult |Div |Le |Ge |Lt |Gt |Eq |PushGlobal (List (Char)) |Push (Int) |Pop (Int) |PushInt (Int) |PushChar (Char) |Slide (Int) |Update (Int) |Pack (Int) (Int) |CaseJump (List (Pair (Int) (Int))) |Split (Int) |JavaCall |StaticJavaCall |GetRuntime |CCall (List (Char)); writeCCaseJumps js = case js of Nil -> []; Cons i is -> ( case i of Pair co adr -> append (",") (append (showInt co) (append (",") (append (showInt adr) (writeCCaseJumps is))))); writeCI i = append ("\n ,")(writeCI2 i); writeCI2 i = case i of Nop -> sNOP ; End -> sEND ; Jump n -> (append sJUMP (append "," (showInt n))) ; Unwind -> sUNWIND; Eval -> sEVAL; Print -> sPRINT; PrintString -> sPRINTSTRING; Output s-> sOUTPUT; MkAp -> sMKAP; Add -> sADD; Sub -> sSUB; Mult-> sMULT; Div -> sDIV; Le -> sLE; Ge -> sGE; Lt -> sLT; Gt -> sGT; Eq -> sEQ; PushGlobal n-> concat [sPUSHGLOBAL,",FUNCTION_INDEX_",n]; Push n-> (append sPUSH (append "," (showInt n))); Pop n-> (append sPOP (append "," (showInt n))); PushInt n-> (append sPUSHINT (append "," (showInt n))); PushChar n-> (append sPUSHCHAR (append "," (showChar n))); Slide n-> (append sSLIDE (append "," (showInt n))); Update n-> (append sUPDATE (append "," (showInt n))); Pack n1 n2 ->concat [sPACK,",",showInt n1,",",showInt n2] ; CaseJump n ->concat [sCASEJUMP,",",showInt (length n),writeCCaseJumps n]; Split n->concat [sSPLIT,",",showInt n]; JavaCall -> sJAVACALL; StaticJavaCall -> sSTATICJAVACALL; GetRuntime -> sGETRUNTIME; CCall s -> (append sCCALL (append (",(int)cfunction_") s)); calcSize xs = case xs of Nil -> 0; Cons y ys -> (instrSize y) + (calcSize ys); instrSize i = case i of Nop -> 1; End -> 1; Jump x->2; Unwind -> 1; Eval -> 1; Print -> 1; MkAp -> 1; Add -> 1; Sub -> 1; Mult -> 1; Div -> 1; Le -> 1; Ge -> 1; Lt -> 1; Gt -> 1; Eq -> 1; PushGlobal n-> 2; Push x -> 2; Pop x-> 2; PushInt x -> 2; PushChar x -> 2; Slide x-> 2; Update x -> 2; Pack x y-> 3; CaseJump ls -> 2+2*(length ls); Split x -> 2; GetRuntime -> 1; CCall x-> 2; writeCIs writer is cfuns = writeCFunsCCode (cappendF writer (concat (listMap writeCI is))) cfuns; main = case getProgArgs of Cons arg args1 -> genCCode arg (fab4P (id (creadF (append arg (".fab4"))))); showInt i = if (i<10) [showDigit i] (append (showInt (i/10)) (showInt (i-i/10*10))); h xs = head xs; showDigit d = if (d=0) '0'(if (d=1) '1' (if (d=2) '2' (if (d=3) '3' (if (d=4) '4' (if (d=5) '5' (if (d=6) '6' (if (d=7) '7' (if (d=8) '8' '9')))))))); showChar c = if (c = '\n') "'\\n'" (if (c = '\\') "'\\\\'" (if (c = ''') "'\\''" (append "'" (Cons c ("'"))))); removeUnused isWhnf code = case code of Nil -> code; Cons c ode -> (case c of Nop -> removeUnused isWhnf ode; Pop n -> if (n=0) (removeUnused isWhnf ode) (Cons c (removeUnused False ode)); End -> Cons c (removeUnused isWhnf ode); Jump x->code; Unwind -> Cons c (removeUnused True ode); Eval -> if (isWhnf) (removeUnused True ode) (Cons c (removeUnused True ode)); Print -> Cons c (removeUnused False ode); MkAp -> Cons c (removeUnused False ode); Add -> Cons c (removeUnused True ode); Sub -> Cons c (removeUnused True ode); Mult -> Cons c (removeUnused True ode); Div -> Cons c (removeUnused True ode); Le -> Cons c (removeUnused True ode); Ge -> Cons c (removeUnused True ode); Lt -> Cons c (removeUnused True ode); Gt -> Cons c (removeUnused True ode); Eq -> Cons c (removeUnused True ode); PushGlobal n-> Cons c (removeUnused False ode); Push x -> Cons c (removeUnused False ode); PushInt x -> Cons c (removeUnused True ode); PushChar x -> Cons c (removeUnused True ode); Slide x-> if (x=0) (removeUnused isWhnf ode) (Cons c (removeUnused isWhnf ode)); Update x -> Cons c (removeUnused False ode); Pack x y-> Cons c (removeUnused True ode); CaseJump ls -> code; Split x -> Cons c (removeUnused False ode); GetRuntime -> Cons c (removeUnused True ode); CCall x-> Cons c (removeUnused True ode)); inferTypes newNames fab4 = case fab4 of Fab4 a constrs funs cfuns dataDefs -> (case mkFunTypes newNames funs of Pair funs2 newNames2 -> Fab4 a constrs (inferFunTypes newNames2 (listMap getFunctionName funs) (bindConstructorTypes dataDefs) (concat [listMap getFunNameType funs2,(listMap pairGetCFunType cfuns) ,[progArgsType]]) funs2) cfuns dataDefs); bindConstructorTypes dataDefs = concat (listMap bindConstructorType dataDefs); bindConstructorType dataDef = case dataDef of DataTypeDef typename typeVars constrAlts -> listMap (getConstrType (AlgType typename (listMap typeVar typeVars))) constrAlts; typeVar x = TypeVar x; cTypes = [("string",AlgType "List" [AlgType "Char" []]) ,("int",AlgType "Int" [])]; getConstrType resultT con = case con of DataTypeAlt name args -> (name,(args,resultT)); getFunType f = case f of FunDef t n args e -> t; getFunNameType f = case f of FunDef t n args e -> (n,t); getFunVarBindings funs = case funs of Nil -> []; Cons f fs -> (case f of FunDef type name args e -> Cons (name,type) (getFunVarBindings fs) ); getCFunName cfun = case cfun of CFunDef a name args result -> name; getCFunType cfun = case cfun of CFunDef a name args result -> (case args of Nil ->(lookUp result cTypes); Cons a rgs -> (FunType (lookUp a cTypes) (getCFunType (CFunDef a name rgs result)) )); pairGetCFunType cfun = (getCFunName cfun,getCFunType cfun); writeInterfaceFile fn fab4 = case (trace "writing interface" fab4) of Fab4 a cs funs cfuns datas -> writeFunInterface (cwriteF fn "") funs; writeFunInterface fn funs = case funs of Nil -> fn; Cons f fs -> case f of FunDef type name vars e -> writeFunInterface (cappendF fn (concat [name," :: ",showType type,";\n"])) fs; mkFunTypes newNames funs = case funs of Nil -> (funs, newNames); Cons f fns -> (case mkFunTypes newNames fns of Pair funs2 newNames2 -> (case f of FunDef a n vars e -> (case (mkFunType newNames2 vars) of Tuple3 newNames3 env res -> (Cons (FunDef res n vars e) funs2,newNames3)))); mkFunType newNames vars = case vars of Nil -> Tuple3 (tail newNames) [] (TypeVar (head newNames)); Cons v vs -> (case (mkFunType newNames vs) of Tuple3 newNames2 varEnv resType -> Tuple3 (tail newNames2) (Cons (v,head newNames2) varEnv) (FunType (TypeVar (head newNames2)) resType)); showSub xs = case xs of Nil -> "[]"; Cons y ys -> Cons '[' (append (showSubEntry y) (showSub2 ys)); showSub2 xs = case xs of Nil -> "]"; Cons y ys -> Cons ',' (append (showSubEntry y) (showSub2 ys)); showSubEntry p = concat ["(",fst p,",",showType (snd p),")"]; unify2 left right sub = case left of TypeVar v -> (case right of TypeVar v2 -> if (stringEq v2 v) (left,sub) (right,(Cons (v,right) (substituteEnv v right sub))); FunType t1 t2 -> (right,Cons (v,right) (substituteEnv v right sub)); AlgType n args -> (right,(Cons (Pair v right) (substituteEnv v right sub))) ); FunType t1 t2 ->(case right of TypeVar v -> (left,Cons (v,left)(substituteEnv v left sub)); FunType t21 t22 ->(case (unify2 t1 t21 sub) of Pair tr1 sub2 ->( case unify2 (substituteSub sub2 t2) (substituteSub sub2 t22) sub2 of Pair tr2 sub3 -> (FunType (substituteSub sub3 tr1) tr2,sub3)) ); AlgType n args -> aborts ["type error:\ncannot unify FunType:\n " ,showType left ,"\nwith AlgType\n " ,showType right] ); AlgType n args ->(case right of TypeVar v -> (left,Cons (v,left) (substituteEnv v left sub)); FunType t1 t2 -> aborts ["type error:\ncannot unify AlgType:\n " ,showType left ,"\nwith FunType\n " ,showType right]; AlgType n2 args2 -> (case (stringEq n n2) of False-> (case and (contains stringEq n ["Int","Char"]) (contains stringEq n2 ["Int","Char"]) of True -> (intType,sub); False -> aborts ["type error: cannot unify: \n" ," ",showType left ,"\n with\n" ," ",showType right ]); True -> (case unificationList2 args args2 sub of Pair rs sub2 -> (AlgType n rs,sub2) )) ); substituteSub sub type = case type of TypeVar v -> subVar sub v; FunType t1 t2 -> FunType (substituteSub sub t1)(substituteSub sub t2); AlgType name args -> AlgType name (listMap (substituteSub sub) args); subVar sub v = case sub of Nil -> TypeVar v; Cons s ub -> (case s of Pair v2 t -> if (stringEq v v2) t (subVar ub v )); applySubToEnv sub env = (listMap (applySubToSnd sub) env); applySubToSnd sub p = (fst p,substituteSub sub (snd p)); unificationList2 xs ys sub = case xs of Nil -> (case ys of Nil -> (Nil,sub); Cons z zs -> abort "type error: wrong number of type parameters"); Cons x1 x1s -> (case ys of Nil -> abort "type error: wrong number of type parameters"; Cons y1 y1s -> (case unify2 x1 y1 sub of Pair xr sub2 -> (case unificationList2 (listMap (substituteSub sub2) x1s) (listMap (substituteSub sub2) y1s) sub2 of Pair xsr sub3 -> (Cons (substituteSub sub3 xr) xsr,sub3) ) ) ); substituteList sub xs = listMap (substituteSub sub) xs; substitute typevar type typeExpr = case typeExpr of TypeVar v -> if (stringEq v typevar) type typeExpr; FunType t1 t2 -> FunType (substitute typevar type t1)(substitute typevar type t2); AlgType n args -> AlgType n (listMap (substitute typevar type) args); substituteEnvPair typevar type p = case p of Pair var t -> (var,substitute typevar type t); substituteEnv typevar type env = case env of Nil -> Nil; Cons x xs -> (listMap (substituteEnvPair typevar type) env); inferFunTypes newNames funNames constrs funTypes funs = case funs of Nil -> []; Cons f uns -> (case f of FunDef t name args e -> trace (concat ["infer type for function: ",name]) (case inferExprType2 (tail newNames) funNames constrs funTypes (Cons (name,t) (mkVarEnv args t)) (getResultType (length args) t) e of Tuple5 newNames2 t1 e1 sub env -> (case Box (mkFinalFunType env args t1) of Box funType -> (Cons (FunDef (normalizeType funType) name args e) (inferFunTypes newNames2 funNames constrs (Cons (name,normalizeType funType) funTypes) uns))))); alphabet = "abcdefghijklmnopqrstuvwxyz"; mkTypeVarFromChar c = TypeVar [c]; collectTypeVars t = case t of TypeVar v -> [v]; FunType t1 t2 ->append (collectTypeVars t1)(collectTypeVars t2); AlgType name ts -> concat (listMap collectTypeVars ts); nub comp xs = case xs of Nil -> []; Cons y ys -> (case Box (nub comp ys) of Box zs -> (case contains comp y zs of True -> zs; False -> Cons y zs )); normalizeType t = case Box (collectTypeVars t) of Box vs -> substituteSub (zip (nub stringEq vs) (listMap mkTypeVarFromChar alphabet)) t; mkFinalFunType2 env args t1 = case args of Nil -> t1; Cons a rgs -> (FunType (lookUp a env) (mkFinalFunType2 env rgs t1)); mkFinalFunType env args t = (mkFinalFunType2 env args t); mkVarEnv args t = case args of Nil -> []; Cons x xs -> (case t of FunType t1 t2 -> Cons (x,t1) (mkVarEnv xs t2)); getResultType n t = case n=0 of True -> t; False-> (case t of FunType t1 t2 -> getResultType (n-1) t2); getParameterBindings type vars = case vars of Nil -> []; Cons v vs -> (case type of FunType t1 t2 -> Cons (v,t1) (getParameterBindings t2 vs) ); addVarPrefix n t = case t of TypeVar v -> TypeVar (append n v); FunType e1 e2 -> FunType (addVarPrefix n e1)(addVarPrefix n e2); AlgType name args -> AlgType name (listMap (addVarPrefix n) args); inEnv x env = case env of Nil -> False; Cons e nv -> (case stringEq (fst e) x of True -> True; False -> inEnv x nv); inferExprType2 newNames funNames constrs funTypes env assumedType e = case e of VarExpr a name -> (case newNames of Cons n newNames2 -> if (inEnv name env) (inferVarType2 newNames2 name (lookUp name env) assumedType env) (inferVarType2 newNames2 name (addVarPrefix n (lookUp name funTypes)) assumedType env) ); ConstructorCall a name args ->inferConstrType newNames funNames constrs funTypes env assumedType name args; NumExpr a i -> (case unify2 assumedType (AlgType "Int" []) [] of Pair r sub -> Tuple5 newNames r (NumExpr r i) sub (applySubToEnv sub env)); CharExpr a i -> (case (unify2 assumedType (AlgType "Char" []) []) of Pair r sub ->Tuple5 newNames r (CharExpr r i) sub (applySubToEnv sub env)); AppExpr a e1 e2 -> inferAppExprType2 e1 e2 newNames funNames constrs funTypes env assumedType; CaseExpr a e2 alts -> inferCaseExpr newNames funNames constrs funTypes env assumedType e2 alts; OpExpr a e1 op e2 -> inferOpExpr newNames funNames constrs funTypes env assumedType e1 e2 op; opTypes = [("+",intType ),("-",intType ),("*",intType ),("/",intType ) ,( "<",boolType) ,(">", boolType) ,("<=",boolType ),(">=", boolType) ,("=",boolType)]; intType = AlgType "Int" []; boolType = AlgType "Bool" []; inferOpExpr newNames funNames constrs funTypes env assumedType e1 e2 op = case forceCharInt newNames funNames constrs funTypes env e1 of Tuple5 newNames2 t1 e1T sub2 env2 -> (case forceCharInt newNames2 funNames constrs funTypes env2 e2 of Tuple5 newNames3 t2 e2T sub3 env3 -> (case unify2 assumedType (lookUp op opTypes) [] of Pair r sub4 -> Tuple5 newNames3 r (OpExpr r e1T op e2T) (append sub4 (applySubToEnv sub4 sub3)) (applySubToEnv sub4 env3))); forceCharInt newNames funNames constrs funTypes env e = case inferExprType2 (tail newNames) funNames constrs funTypes env (TypeVar (head newNames)) e of Tuple5 newNames2 t eT sub2 env2 -> (case t of TypeVar v1 -> inferExprType2 newNames funNames constrs funTypes env intType e; AlgType n args -> (case or (stringEq n "Char") (stringEq n "Int") of True -> Tuple5 newNames2 t eT sub2 env2; False -> abort "Type error" )); inferConstrType newNames funNames constrs funTypes env assumedType name args = case lookUp name constrs of Pair argsT resT -> (case inferExprList (tail newNames) funNames constrs funTypes env assumedType name (listMap (addVarPrefix (head newNames)) argsT) args [] of Tuple4 newNames2 rs sub env -> (case unify2 (substituteSub sub (addVarPrefix (head newNames) resT)) assumedType sub of Pair res sub2 -> Tuple5 newNames2 res (ConstructorCall res name rs) sub2 (applySubToEnv sub2 env))); inferVarType2 newNames name varType assumedType env = case ( unify2 assumedType varType []) of Pair r sub -> (Tuple5 newNames (substituteSub sub r) (VarExpr r name) sub (applySubToEnv sub env)); mapExpr f e = case e of VarExpr t v -> VarExpr (f t) v; ConstructorCall a n xs -> ConstructorCall (f a) n xs; NumExpr a i -> NumExpr (f a) i; CharExpr a c -> CharExpr (f a) c; AppExpr a e1 e2 -> AppExpr (f a) e1 e2; CaseExpr a e as -> CaseExpr (f a) e as; OpExpr a e1 op e2 -> OpExpr (f a) e1 op e2; inferExprList newNames funNames constrs funTypes env assumedType name argsT args sub = case args of Nil -> (case argsT of Cons k ks -> aborts ["wrong number of arguments to constructor: ",name]; Nil -> Tuple4 newNames (Nil) sub env ); Cons a rgs -> (case argsT of Nil -> aborts ["wrong number of arguments to constructor: ",name]; Cons aT rgsT -> (case inferExprType2 newNames funNames constrs funTypes env aT a of Tuple5 newNames2 t e sub2 env2 -> (case Box (append sub2 (applySubToEnv sub2 sub)) of Box sub3 -> (case inferExprList newNames2 funNames constrs funTypes env2 assumedType name (listMap (substituteSub sub3) rgsT) rgs sub3 of Tuple4 newNames3 es sub4 env3 -> Tuple4 newNames3 (Cons (mapExpr (substituteSub sub4) e) es) sub4 env3 )))); inferAppExprType2 e1 e2 newNames funNames constrs funTypes env assumedType = case newNames of Cons n1 newNames2 -> (case newNames2 of Cons n2 newNames3 -> (case inferExprType2 newNames3 funNames constrs funTypes env (TypeVar n1) e2 of Tuple5 newNames4 argType er1 sub env2 -> (case (inferExprType2 newNames4 funNames constrs funTypes env2 (FunType argType (TypeVar n2)) e1) of Tuple5 newNames5 funType fr sub2 env3 -> (case funType of FunType t1 t2 -> (case unify2 assumedType t2 (append sub2 (applySubToEnv sub2 sub)) of Pair rsAll sub3 -> (Tuple5 newNames5 rsAll (AppExpr rsAll e1 e2) sub3 (applySubToEnv sub3 (applySubToEnv sub2 env3)) ) ); TypeVar v -> abort ("issnichsollte nich sein"))))); inferCaseExpr newNames funNames constrs funTypes env assumedType e alts = case inferExprType2 (tail newNames) funNames constrs funTypes env (TypeVar (head newNames)) e of Tuple5 newNames2 eT expr sub env2 -> inferCaseAlts newNames2 funNames constrs funTypes sub env2 (substituteSub sub assumedType) eT alts; inferCaseAlts newNames funNames constrs funTypes sub env assumedType eT alts = case alts of Nil -> abort "strange: empty list of case alternatives"; Cons a lts -> (case inferCaseAlt newNames funNames constrs funTypes sub env assumedType eT a of Tuple6 newNames2 aT aE eT2 sub2 env2 -> (case lts of Nil -> (Tuple5 newNames2 aT aE sub2 env2); Cons l ts -> inferCaseAlts newNames2 funNames constrs funTypes sub2 env2 aT eT2 lts)); compose f g x = f(g x); inferCaseAlt newNames funNames constrs funTypes sub env assumedType eT al = case al of CaseAlt a n vars e -> (case lookUp n constrs of Pair args res -> (case ((length args) = (length vars)) of True -> (case unify2 (addVarPrefix (head newNames) res) eT sub of Pair ttt sub2 -> (case Box (listMap (compose (substituteSub sub2) (addVarPrefix (head ( newNames))) ) args) of Box argTs -> (case inferExprType2 (tail newNames) funNames constrs funTypes (append (zip vars argTs) (applySubToEnv sub2 env)) (substituteSub sub2 assumedType) e of Tuple5 newNames2 theT theE theSub theEnv -> (Tuple6 newNames2 (substituteSub theSub theT) theE (substituteSub theSub ttt) theSub (drop (length vars) theEnv))))); False -> aborts ["wrong number of args in pattern for constructor: " ,n] )); showExpr e = case e of VarExpr a name -> name; ConstructorCall a name es -> concat ["(",name," ",concat (listMap showExpr es),")"]; NumExpr a i -> showInt i; CharExpr a i -> [''',i,''']; AppExpr a e1 e2 -> concat ["(",showExpr e1," ",showExpr e2,")"]; CaseExpr a e2 alts -> concat (append ["case ",showExpr e2," of\n"] (listMap showAlt alts)); OpExpr a e1 op e2 -> concat ["(",showExpr e1,op,showExpr e2,")"]; showAlt a = case a of CaseAlt t n xs e -> concat ["\n ",n ,concat (listMap addWhite xs) ," -> " ,(showExpr e)] ; addWhite x = append x " "