diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 416383a..0abf9b4 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -29,24 +29,26 @@ jobs: - name: Build runner run: | smackage source typeclasses git git://github.com/ProjectSavanna/typeclasses.git + smackage source bananas git git://github.com/ProjectSavanna/bananas.git smackage refresh smackage get typeclasses v1 + smackage get bananas v1 echo "SMACKAGE $HOME/.smackage/lib" > pathconfig - mkdir bin - CM_LOCAL_PATHCONFIG=pathconfig ml-build run.cm Run.run bin/run - rm pathconfig - - - name: Run formatter - run: | - for file in test/*.input.sml; do - sml @SMLload=bin/run "$file" "test/$(basename "$file" .input.sml).output.sml" || ( - echo "::error::Error when formatting test case file: $file" && exit 1 - ) - done - - - name: Update test case outputs - uses: stefanzweifel/git-auto-commit-action@v4 - with: - file_pattern: test/*.output.sml - commit_message: Update test case outputs - if: ${{ github.event_name == 'push' && matrix.smlnj-version == '110.98' }} + # mkdir bin + # CM_LOCAL_PATHCONFIG=pathconfig ml-build run.cm Run.run bin/run + # rm pathconfig + + # - name: Run formatter + # run: | + # for file in test/*.input.sml; do + # sml @SMLload=bin/run "$file" "test/$(basename "$file" .input.sml).output.sml" || ( + # echo "::error::Error when formatting test case file: $file" && exit 1 + # ) + # done + + # - name: Update test case outputs + # uses: stefanzweifel/git-auto-commit-action@v4 + # with: + # file_pattern: test/*.output.sml + # commit_message: Update test case outputs + # if: ${{ github.event_name == 'push' && matrix.smlnj-version == '110.98' }} diff --git a/src/autoformat.sig b/src/autoformat.sig deleted file mode 100644 index 2560858..0000000 --- a/src/autoformat.sig +++ /dev/null @@ -1 +0,0 @@ -signature AUTOFORMAT = SHOW where type t = Ast.dec diff --git a/src/autoformat.sml b/src/autoformat.sml deleted file mode 100644 index c45d8ed..0000000 --- a/src/autoformat.sml +++ /dev/null @@ -1,549 +0,0 @@ -structure AutoFormat :> AUTOFORMAT = - struct - structure A = Ast - - type t = A.dec - - local - infix |> - fun x |> f = f x - - exception Invalid of string - - val printTys = fn f => fn - nil => "" - | [tyvar] => f tyvar ^ " " - | tyvars => "(" ^ String.concatWithMap "," f tyvars ^ ") " - - val indent = List.map (fn "" => "" | s => " " ^ s) - val rec putOnFirst = fn s => fn - nil => nil - | x :: xs => s ^ x :: xs - val rec putOnLast = fn s => fn - nil => nil - | [x] => [x ^ s] - | x :: xs => x :: putOnLast s xs - - val rec separateWithNewlines = fn f => fn - nil => nil - | x :: xs => List.tl (List.concatMap (Fn.curry (op ::) "" o f) (x :: xs)) - - val removeWhitespace = String.translate (fn #" " => "" | c => str c) - fun commas sep [] = [] - | commas sep [x] = x - | commas sep (x::xs) = putOnLast sep x @ commas sep xs - val iterFormat = fn { init = init, sep = sep, final = final, fmt = fmt } => fn l => ( - let - val l' = List.map fmt l - in - { - string = - if List.exists (fn l => List.length l > 1) l' - then removeWhitespace init :: indent (commas sep l') @ [removeWhitespace final] - else [ListFormat.fmt { init = init, sep = sep ^ " ", final = final, fmt = Fn.id } (List.concat l')], - safe = true - } - end - ) - - val printPath = fn - nil => raise Invalid "empty path" - | path => String.concatWithMap "." Symbol.name path - - val listToString = fn toString => ListFormat.fmt { init = "[", sep = ", ", final = "]", fmt = toString} - val tupleToString = fn toString => ListFormat.fmt { init = "(", sep = ", ", final = ")", fmt = toString} - - val concatMapWith = fn sep => fn init => fn f => - List.concatMapi (fn (0,x) => f (init,x) | (_,x) => f (sep,x)) - val concatMapAnd = fn keyword => concatMapWith "and " keyword (* eta-expanded to account for NJ bug? *) - - val wrapStr = fn - {string = string, safe = false} => "(" ^ string ^ ")" - | {string = string, safe = true } => string - val wrapList = fn - {string = [line], safe = false} => ["(" ^ line ^ ")"] - | {string = string, safe = false} => "(" :: indent string @ [")"] - | {string = string, safe = true } => string - - val rec printExp = fn - A.VarExp path => {string = [printPath path], safe = true} - | A.FnExp rules => { - string = - case printRules rules of - [rule] => ( - case rule of - [line] => ["fn " ^ line] - | lines => putOnFirst "fn " lines - ) - | lines => concatMapWith " | " "fn " (Fn.uncurry putOnFirst) lines, - safe = false - } - | A.FlatAppExp exps => ( - case exps of - nil => raise Invalid "empty FlatAppExp" - | [exp] => printExp (#item exp) - | _ => { - string = - let - val l' = List.map (printExp' o #item) exps - in - if List.exists (fn l => List.length l > 1) l' - then commas " " l' - else [ListFormat.fmt { init = "", sep = " ", final = "", fmt = Fn.id } (List.concat l')] - end, - safe = false - } - ) - | A.AppExp {function=function,argument=argument} => { - string = - case (printExp' function, printExp' argument) of - ([fLine],[aLine]) => [fLine ^ " " ^ aLine] - | ([fLine],aLines) => fLine :: indent aLines - | (fLines,aLines) => fLines @ indent aLines, - safe = false - } - | A.CaseExp {expr=expr,rules=rules} => { - string = - case printExp' expr of - [line] => "case " ^ line ^ " of" :: concatMapWith "| " " " (Fn.uncurry putOnFirst) (printRules rules) - | lines => putOnLast " of" (putOnFirst "case " lines) @ concatMapWith "| " " " (Fn.uncurry putOnFirst) (printRules rules), - safe = false - } - | A.LetExp {dec=dec, expr=expr} => {string = "let" :: indent (printDec dec) @ ["in"] @ indent (printExp' expr) @ ["end"], safe = true} - | A.SeqExp exps => ( - case exps of - nil => raise Invalid "empty SeqExp" - | [e] => printExp e - | _ => iterFormat { init = "(", sep = ";", final = ")", fmt = #string o printExp} exps - ) - | A.IntExp (s,_) => {string = [s], safe = true} - | A.WordExp (s,_) => {string = [s], safe = true} - | A.RealExp (s,_) => {string = [s], safe = true} - | A.StringExp s => {string = ["\"" ^ String.toString s ^ "\""], safe = true} - | A.CharExp s => {string = ["#\"" ^ String.toString s ^ "\""], safe = true} - | A.ListExp exps => iterFormat { init = "[", sep = ",", final = "]", fmt = #string o printExp} exps - | A.RecordExp l => ( - case l of - nil => {string = ["()"], safe = true} - | _ => iterFormat { init = "{ ", sep = ",", final = " }", fmt = (fn (sym,exp) => case #string (printExp exp) of [line] => [Symbol.name sym ^ " = " ^ line] | lines => Symbol.name sym ^ " =" :: indent lines)} l - ) - | A.TupleExp exps => iterFormat { init = "(", sep = ",", final = ")", fmt = #string o printExp} exps - | A.SelectorExp sym => {string = ["#" ^ Symbol.name sym], safe = true} - | A.ConstraintExp {expr=exp,constraint=ty} => {string = putOnLast (" : " ^ printTy ty) (printExp' exp), safe = false} - | A.HandleExp {expr=exp,rules=rules} => { - string = - case printExp' exp of - [line] => putOnFirst line (concatMapWith (StringCvt.padLeft #" " (8 + String.size line) " | ") " handle " (Fn.uncurry putOnFirst) (printRules rules)) - | lines => lines @ concatMapWith " | " "handle " (Fn.uncurry putOnFirst) (printRules rules), - safe = false - } - | A.RaiseExp exp => {string = putOnFirst "raise " (#string (printExp exp)), safe = false} - | A.IfExp {test=test,thenCase=thenCase,elseCase=elseCase} => { - string = - case (#string (printExp test), #string (printExp thenCase), #string (printExp elseCase)) of - ([testLine],[thenLine],[elseLine]) => ["if " ^ testLine ^ " then " ^ thenLine ^ " else " ^ elseLine] - | ([testLine],thenLines,elseLines) => "if " ^ testLine :: indent ("then" :: indent thenLines @ ["else"] @ indent elseLines) - | (testLines,thenLines,elseLines) => "if" :: indent (testLines @ "then" :: indent thenLines @ ["else"] @ indent elseLines), - safe = false - } - | A.AndalsoExp (e1,e2) => { - string = - case (#string (printExp e1), #string (printExp e2)) of - ([line1],[line2]) => [line1 ^ " andalso " ^ line2] - | ([line1],lines2) => line1 ^ " andalso" :: lines2 - | (lines1,[line2]) => lines1 @ ["andalso " ^ line2] - | (lines1,lines2) => lines1 @ [" andalso "] @ lines2, - safe = false - } - | A.OrelseExp (e1,e2) => { - string = - case (#string (printExp e1), #string (printExp e2)) of - ([line1],[line2]) => [line1 ^ " orelse " ^ line2] - | ([line1],lines2) => line1 ^ " orelse" :: lines2 - | (lines1,[line2]) => lines1 @ ["orelse " ^ line2] - | (lines1,lines2) => lines1 @ [" orelse "] @ lines2, - safe = false - } - | A.VectorExp exps => raise Invalid "vectors not supported" - | A.WhileExp {test=test,expr=expr} => { - string = - case (#string (printExp test), #string (printExp expr)) of - ([lineTest],[lineExpr]) => ["while " ^ lineTest ^ " do " ^ lineExpr] - | ([lineTest],linesExpr) => "while " ^ lineTest ^ " do" :: linesExpr - | (linesTest,linesExpr) => "while" :: linesTest @ [" do"] @ linesExpr, - safe = false - } - | A.MarkExp (exp,_) => printExp exp - and printExp' = fn exp => wrapList (printExp exp) - and printRules = fn rules => ( - let - val wrap' = - case rules of - nil => raise Invalid "empty rules" - | [r] => #string - | _ => wrapList - - val printed = List.map (fn A.Rule {pat=pat,exp=exp} => {pat = #string (printPat pat), exp=wrap' (printExp exp)}) rules - val pad = - printed - |> List.map (String.size o #pat) - |> List.foldr Int.max 0 - |> StringCvt.padRight #" " - in - List.map - (fn {pat=pat,exp=exp} => putOnFirst (pad pat ^ " => ") exp) - printed - end - ) - and printPat = fn - A.WildPat => {string = "_", safe = true} - | A.VarPat path => {string = printPath path, safe = true} - | A.IntPat (s,_) => {string = s, safe = true} - | A.WordPat (s,_) => {string = s, safe = true} - | A.StringPat s => {string = "\"" ^ String.toString s ^ "\"", safe = true} - | A.CharPat s => {string = "#\"" ^ String.toString s ^ "\"", safe = true} - | A.RecordPat {def=defs,flexibility=flexibility} => { - string = - case defs of - nil => "()" - | _ => ListFormat.fmt { init = "{", sep = ", ", final = if flexibility then ", ...}" else "}", fmt = fn (sym,pat) => Symbol.name sym ^ " = " ^ #string (printPat pat)} defs, - safe = true - } - | A.ListPat pats => {string = listToString (#string o printPat) pats, safe = true} - | A.TuplePat pats => {string = tupleToString (#string o printPat) pats, safe = true} - | A.FlatAppPat pats => ( - case pats of - nil => raise Invalid "empty FlatAppPat" - | [pat] => printPat (#item pat) - | _ => {string = String.concatWith " " (List.map (printPat' o #item) pats), safe = false} - ) - | A.AppPat {constr=constr,argument=argument} => {string = printPat' constr ^ " " ^ printPat' argument, safe = false} - | A.ConstraintPat {pattern=pat,constraint=ty} => {string = printPat' pat ^ " : " ^ printTy ty, safe = false} - | A.LayeredPat {varPat=varPat,expPat=expPat} => {string = printPat' varPat ^ " as " ^ printPat' expPat, safe = false} - | A.VectorPat pats => raise Invalid "vectors not supported" - | A.MarkPat (pat,_) => printPat pat - | A.OrPat pats => ( - case pats of - nil => raise Invalid "empty OrPat" - | [pat] => printPat pat - | _ => {string = ListFormat.fmt { init = "(", sep = " | ", final = ")", fmt = #string o printPat} pats, safe = true} - ) - and printPat' = fn pat => wrapStr (printPat pat) - and printStrexp = fn - A.VarStr path => [printPath path] - | A.BaseStr dec => ( - case indent (printDec dec) of - nil => ["struct end"] - | lines => "struct" :: lines @ ["end"] - ) - | A.ConstrainedStr (strexp,sigconst) => ( - case printSigConst sigconst of - [line] => putOnLast line (printStrexp strexp) - | lines => printStrexp strexp @ lines - ) - | (A.AppStr (path,args) | A.AppStrI (path,args)) => ( - case args of - [(strexp,_)] => ( - case printStrexp strexp of - [line] => [printPath path ^ " (" ^ line ^ ")"] - | lines => printPath path ^ " (" :: indent lines @ [")"] - ) - | _ => raise Invalid "higher-order modules not supported" - ) - | A.LetStr (dec,strexp) => "let" :: indent (printDec dec) @ ["in"] @ indent (printStrexp strexp) @ ["end"] - | A.MarkStr (strexp,_) => printStrexp strexp - and printFctexp = fn - A.BaseFct {params=params,body=body,constraint=constraint} => ( - case params of - [(nameOpt,sg)] => ( - let - val initial = ( - case nameOpt of - NONE => - let - val rec getSpecs = fn - A.BaseSig specs => specs - | A.MarkSig (sigexp,_) => getSpecs sigexp - | _ => raise Fail "expected spec in functor definition" - in - case separateWithNewlines printSpec (getSpecs sg) of - [line] => [" (" ^ line ^ ")"] - | lines => " (" :: indent lines @ [")"] - end - | SOME name => ( - case printSigexp sg of - [line] => [" (" ^ Symbol.name name ^ " : " ^ line ^ ")"] - | lines => " (" ^ Symbol.name name ^ " :" :: indent (printSigexp sg) @ [")"] - ) - ) - val withConstraint = - putOnLast " =" ( - case printSigConst constraint of - nil => initial - | l :: ls => putOnLast l initial @ indent ls - ) - in - case printStrexp body of - [line] => putOnLast (" " ^ line) withConstraint - | lines => withConstraint @ indent lines - end - ) - | _ => raise Invalid "higher-order functors not supported" - ) - | A.MarkFct (fctexp,_) => printFctexp fctexp - | _ => raise Invalid "extra functor syntaxes not supported" - and printWherespec = fn - A.WhType (path,tyvars,ty) => "type " ^ printTys printTyvar tyvars ^ printPath path ^ " = " ^ printTy ty - | A.WhStruct (src,dst) => printPath src ^ " = " ^ printPath dst - and printSigexp = fn - A.VarSig sym => [Symbol.name sym] - | A.AugSig (sigexp,wherespecs) => ( - printSigexp sigexp - @ ( - wherespecs - |> concatMapAnd "where " (fn (kw,wherespec) => [kw ^ printWherespec wherespec]) - ) - ) - | A.BaseSig specs => ( - case separateWithNewlines printSpec specs of - nil => ["sig end"] - | lines => "sig" :: indent lines @ ["end"] - ) - | A.MarkSig (sigexp,_) => printSigexp sigexp - and printSpec = fn - A.StrSpec structures => ( - structures - |> concatMapAnd "structure " ( - fn (kw,(name,sigexp,pathOpt)) => - case printSigexp sigexp of - [line] => [kw ^ Symbol.name name ^ " : " ^ line] - | lines => kw ^ Symbol.name name ^ " :" :: indent lines - ) - ) - | A.TycSpec (types,eq) => ( - types - |> concatMapAnd (if eq then "eqtype " else "type ") ( - fn (kw,(name,tyvars,tyOpt)) => [kw ^ printTys printTyvar tyvars ^ Symbol.name name - ^ (case tyOpt of NONE => "" | SOME ty => " = " ^ printTy ty)] - ) - ) - | A.FctSpec _ => raise Invalid " ignored" - | A.ValSpec vals => ( - vals - |> concatMapAnd "val " (fn (kw,(name,ty)) => [kw ^ Symbol.name name ^ " : " ^ printTy ty]) - ) - | A.DataSpec {datatycs=datatycs, withtycs=withtycs} => ( - case withtycs of - nil => concatMapAnd "datatype " (fn (kw,db) => case printDb db of [line] => [kw ^ line] | lines => kw :: indent lines) datatycs - | _ => raise Invalid "nonempty withtycs" - ) - | A.DataReplSpec (name,path) => ["datatype " ^ Symbol.name name ^ " = datatype " ^ printPath path] - | A.ExceSpec exns => ( - exns - |> concatMapAnd "exception " ( - fn (kw,(name,tyOpt)) => [ - kw ^ Symbol.name name ^ ( - case tyOpt of - NONE => "" - | SOME ty => " of " ^ printTy ty - ) - ] - ) - ) - | A.ShareStrSpec paths => ["sharing " ^ String.concatWithMap " = " printPath paths] - | A.ShareTycSpec paths => ["sharing type " ^ String.concatWithMap " = " printPath paths] - | A.IncludeSpec sigexp => ( - case printSigexp sigexp of - nil => nil - | line :: lines => "include " ^ line :: lines - ) - | A.MarkSpec (spec,_) => printSpec spec - and printSigConst = fn - A.NoSig => nil - | A.Transparent sg => ( - case printSigexp sg of - [line] => [" : " ^ line] - | lines => ":" :: lines - ) - | A.Opaque sg => ( - case printSigexp sg of - [line] => [" :> " ^ line] - | lines => ":>" :: lines - ) - and printDec = fn - A.ValDec (vbs,tyvars) => ( - vbs - |> List.map printVb - |> concatMapAnd ("val " ^ printTys printTyvar tyvars) ( - fn (kw,{pat=pat,exp=[line]}) => [kw ^ pat ^ " = " ^ line] - | (kw,{pat=pat,exp=lines}) => kw ^ pat ^ " =" :: indent lines - ) - ) - | A.ValrecDec (rbvs,tyvars) => ( - rbvs - |> List.map printRvb - |> concatMapAnd ("val rec " ^ printTys printTyvar tyvars) ( - fn (kw,{init=init,exp=[line]}) => [kw ^ init ^ " = " ^ line] - | (kw,{init=init,exp=lines}) => kw ^ init ^ " =" :: indent lines - ) - ) - | A.DoDec _ => raise Invalid "unsupported declaration: 'do'" - | A.FunDec (fbs,tyvars) => ( - fbs - |> List.map printFb - |> concatMapAnd ("fun " ^ printTys printTyvar tyvars) (Fn.uncurry putOnFirst) - ) - | A.TypeDec tbs => ( - tbs - |> List.map printTb - |> concatMapAnd "type " (fn (kw,str) => [kw ^ str]) - ) - | A.DatatypeDec {datatycs=datatycs,withtycs=withtycs} => ( - ( - concatMapAnd "datatype " ( - fn (kw,db) => - case printDb db of - [line] => [kw ^ line] - | lines => kw :: indent lines - ) datatycs - ) @ concatMapAnd "withtype " (fn (kw,db) => [kw ^ printTb db]) withtycs - ) - | A.DataReplDec (name,path) => ["datatype " ^ Symbol.name name ^ " = datatype " ^ printPath path] - | A.AbstypeDec {abstycs=abstycs,withtycs=withtycs,body=body} => ( - ( - concatMapAnd "abstype " ( - fn (kw,db) => - case printDb db of - [line] => [kw ^ line] - | lines => kw :: indent lines - ) abstycs - ) @ concatMapAnd "withtype " (fn (kw,db) => [kw ^ printTb db]) withtycs - @ "with" :: indent (printDec body) @ ["end"] - ) - | A.ExceptionDec ebs => ( - ebs - |> List.map printEb - |> concatMapAnd "exception " (fn (kw,str) => [kw ^ str]) - ) - | A.StrDec strbs => ( - strbs - |> List.map printStrb - |> concatMapAnd "structure " (fn (kw,{name=name,def=def,constraint=constraint}) => - let - val decl = - putOnLast " =" ( - case constraint of - nil => [kw ^ name] - | [l] => [kw ^ name ^ l] - | l::ls => kw ^ name ^ l :: indent ls - ) - in - case def of - nil => decl - | [l] => putOnLast (" " ^ l) decl - | _ => decl @ indent def - end - ) - ) - | A.FctDec fctbs => ( - fctbs - |> List.map printFctb - |> concatMapAnd "functor " (fn (kw,{name=name,def=def}) => putOnFirst (kw ^ name) def) - ) - | A.SigDec sigbs => ( - sigbs - |> List.map printSigb - |> concatMapAnd "signature " ( - fn (kw,{name=name,def=[line]}) => [kw ^ name ^ " = " ^ line] - | (kw,{name=name,def=def }) => kw ^ name ^ " =" :: indent def - ) - ) - | A.FsigDec _ => raise Invalid "funsig not supported" - | A.LocalDec (dec1,dec2) => "local" :: indent (printDec dec1) @ ["in"] @ indent (printDec dec2) @ ["end"] - | A.SeqDec decs => separateWithNewlines printDec decs - | A.OpenDec paths => ["open " ^ String.concatWithMap " " printPath paths] - | A.OvldDec _ => raise Invalid "not available in external language" - | A.FixDec {fixity=fixity, ops=ops} => [Fixity.fixityToString fixity ^ String.concatWithMap " " Symbol.name ops] - | A.MarkDec (dec,_) => printDec dec - and printVb = fn - A.Vb {pat=pat,exp=exp,lazyp=_} => { pat = #string (printPat pat), exp = #string (printExp exp) } - | A.MarkVb (vb,_) => printVb vb - and printRvb = fn - A.Rvb {var=var,fixity=fixity,exp=exp,resultty=resulttyOpt,lazyp=_} => { - init = - ( - if Option.isNone fixity - then "op " - else "" - ) ^ - Symbol.name var ^ ( - case resulttyOpt of - NONE => "" - | SOME ty => " : " ^ printTy ty - ), - exp = #string (printExp exp) - } - | A.MarkRvb (rvb,_) => printRvb rvb - and printFb = fn - A.Fb (clauses,_) => concatMapWith " | " "" (fn (kw,clause) => (putOnFirst kw o printClause) clause) clauses - | A.MarkFb (fb,_) => printFb fb - and printClause = fn - A.Clause {pats=pats,resultty=resulttyOpt,exp=exp} => - putOnFirst ( - String.concatWithMap " " (printPat' o #item) pats ^ ( - case resulttyOpt of - NONE => "" - | SOME ty => " : " ^ printTy ty - ) ^ " = " - ) (printExp' exp) - and printTb = fn - A.Tb {tyc=tyc,def=def,tyvars=tyvars} => printTys printTyvar tyvars ^ Symbol.name tyc ^ " = " ^ printTy def - | A.MarkTb (tb,_) => printTb tb - and printDb = fn - A.Db {tyc=tyc, tyvars=tyvars, rhs=rhs, lazyp=_} => [ - printTys printTyvar tyvars ^ Symbol.name tyc ^ " = " ^ - String.concatWithMap " | " (fn (name,NONE) => Symbol.name name | (name,SOME ty) => Symbol.name name ^ " of " ^ printTy ty) rhs - ] - | A.MarkDb (db,_) => printDb db - and printEb = fn - A.EbGen {exn=exn,etype=etypeOpt} => Symbol.name exn ^ ( - case etypeOpt of - NONE => "" - | SOME ty => " of " ^ printTy ty - ) - | A.EbDef {exn=exn,edef=edef} => Symbol.name exn ^ " = " ^ printPath edef - | A.MarkEb (eb,_) => printEb eb - and printStrb = fn - A.Strb {name=name,def=def,constraint=constraint} => {name=Symbol.name name, def=printStrexp def, constraint=printSigConst constraint} - | A.MarkStrb (strb,_) => printStrb strb - and printFctb = fn - A.Fctb {name=name,def=def} => {name=Symbol.name name,def=printFctexp def} - | A.MarkFctb (fctb,_) => printFctb fctb - and printSigb = fn - A.Sigb {name=name,def=def} => {name=Symbol.name name,def=printSigexp def} - | A.MarkSigb (sigb,_) => printSigb sigb - and printTyvar = fn - A.Tyv a => Symbol.name a - | A.MarkTyv (tyvar,_) => printTyvar tyvar - and printTy = fn - A.VarTy tyvar => printTyvar tyvar - | A.ConTy (path,tyvars) => printTys printTy tyvars ^ printPath path - | A.RecordTy fields => ( - case fields of - nil => "unit" - | _ => - ListFormat.fmt - { - init = "{ ", - sep = ", ", - final = " }", - fmt = fn (name,ty) => Symbol.name name ^ " : " ^ printTy ty - } - fields - ) - | A.TupleTy tys => String.concatWithMap " * " printTy tys - | A.MarkTy (ty,_) => printTy ty - in - val toString = String.concat o List.map (fn s => s ^ "\n") o printDec - end - end diff --git a/src/parse-tree.sml b/src/parse-tree.sml new file mode 100644 index 0000000..7bb5700 --- /dev/null +++ b/src/parse-tree.sml @@ -0,0 +1,428 @@ +functor AddMeta (type meta) (F : FUNCTOR) :> FUNCTOR where type 'a t = { meta : meta, data : 'a F.t } = + struct + type 'a t = { meta : meta, data : 'a F.t } + + val map = fn f => + fn { meta = meta, data = data } => { meta = meta, data = F.map f data } + end + +functor AddMeta2 (type meta) (F : FUNCTOR2) :> FUNCTOR2 where type ('a1, 'a2) t = { meta : meta, data : ('a1, 'a2) F.t } = + struct + type ('a1, 'a2) t = { meta : meta, data : ('a1, 'a2) F.t } + + val map = fn f => + fn { meta = meta, data = data } => { meta = meta, data = F.map f data } + end + +type meta = { + comment : string option +} + +functor ParseTree (Template : FUNCTOR) = + Recursive (AddMeta (type meta = meta) (Template)) + +functor ParseTree2 ( + structure Template1 : FUNCTOR2 + structure Template2 : FUNCTOR2 +) = + Recursive2 ( + structure Template1 = AddMeta2 (type meta = meta) (Template1) + structure Template2 = AddMeta2 (type meta = meta) (Template2) + ) +signature SYMBOL = + sig + include READ SHOW + end + +local + structure Ident :> SYMBOL = + struct + type t = string + val fromString = SOME + val toString = Fn.id + end +in + structure VId = Ident + and TyVar = Ident + and TyCon = Ident + and Lab = Ident + and StrId = Ident +end + +functor Long (Ident : SHOW) = + struct + local + structure Template' = + struct + datatype 'long t + = Ident of Ident.t + | Module of StrId.t * 'long + + fun map f = + fn Ident id => Ident id + | Module (strid, long) => Module (strid, f long) + end + + structure R = Recursive (Template') + in + open R + + structure Template = Template' + + val toString = + R.fold ( + let + open Template + in + fn Ident id => Ident.toString id + | Module (strid, long) => StrId.toString strid ^ "." ^ long + end + ) + end + end + +structure LongVId = Long (VId) + and LongTyCon = Long (TyCon) + and LongStrId = Long (StrId) + +structure SCon = + struct + datatype t + = Int of int + | Real of real + | Word of word + | Char of char + | String of string + + val toString = + fn Int i => Int.toString i + | Real r => Real.toString r + | Word w => Word.toString w + | Char c => Char.toString c + | String s => String.toString s + end + +structure Op = + struct + type 'a t = { hasOp : bool, data : 'a } + + val map = fn f => fn { hasOp , data } => + { hasOp = hasOp, data = f data } + + val toString = fn f => fn { hasOp, data } => + if hasOp + then "op " ^ f data + else f data + end + +structure Util = + struct + local + fun aux stop sep f nil = stop + | aux stop sep f (x :: nil) = f x ^ stop + | aux stop sep f (x :: xs) = f x ^ sep ^ aux stop sep f xs + in + val format = fn { start, stop, sep } => fn f => fn l => start ^ aux stop sep f l + end + + val hasType = fn (obj, ty) => obj ^ " : " ^ ty + end + +structure List = + struct + open List + + type 'a t = 'a list + val toString = fn f => Util.format { start = "[", stop = "]", sep = ", " } f + end + +structure Seq = + struct + type 'a t = 'a list + val map = List.map + end + +structure Seq1 = + struct + type 'a t = 'a * 'a list + val map = fn f => fn (x1, xs) => (f x1, List.map f xs) + end + +structure Tuple = + struct + type 'a t = 'a * 'a * 'a list + val map = fn f => fn (x1, x2, xs) => (f x1, f x2, List.map f xs) + + val toString : ('a -> string) -> 'a t -> string = + fn f => fn (x1, x2, xs) => "(" ^ f x1 ^ String.concat (List.map (fn x => ", " ^ f x) (x2 :: xs)) ^ ")" + end + +structure Seq2 = + struct + type 'a t = 'a * 'a * 'a list + val map = fn f => fn (x1, x2, xs) => (f x1, f x2, List.map f xs) + end + +structure Ty = + struct + datatype 'ty t + = Var of TyVar.t + | Cons of 'ty Seq.t * LongTyCon.t + | Record of (Lab.t * 'ty) list + | Tuple of 'ty Seq2.t + | Arrow of { dom : 'ty, cod : 'ty } + + fun map f = + fn Var tyvar => Var tyvar + | Cons (tyseq, longtycon) => Cons (Seq.map f tyseq, longtycon) + | Record tyrows => Record (List.map (fn (lab, ty) => (lab, f ty)) tyrows) + | Tuple tys => Tuple (Seq2.map f tys) + | Arrow { dom = dom, cod = cod } => Arrow { dom = f dom, cod = f cod } + end + +structure Ty' = Recursive (Ty) + +structure Pat = + struct + datatype 'pat t + = Wildcard + | SCon of SCon.t + | Var of LongVId.t Op.t + (* | Record *) + | Unit + | Tuple of 'pat Tuple.t + | List of 'pat list + | Constructor of LongVId.t Op.t * 'pat + | InfixConstructor of 'pat * VId.t * 'pat + | Typed of 'pat * Ty'.t + + fun map f = + fn Wildcard => Wildcard + | SCon scon => SCon scon + | Var id => Var id + | Unit => Unit + | Tuple pats => Tuple (Tuple.map f pats) + | List pats => List (List.map f pats) + | Constructor (id, pat) => Constructor (id, f pat) + | InfixConstructor (pat1, id, pat2) => InfixConstructor (f pat1, id, f pat2) + | Typed (pat, ty) => Typed (f pat, ty) + end + +structure Pat' = Recursive (Pat) + +functor Precedence (Precedence : ORDERED) :> + sig + type t + val hide : Precedence.t -> string -> t + val show : Precedence.t -> t -> string + end = + struct + type t = { precedence : Precedence.t, string : string } + + val hide = fn precedence => fn s => { precedence = precedence, string = s } + + val op <= = fn (precedence1, precedence2) => + case Precedence.compare (precedence1, precedence2) of + LESS => true + | EQUAL => true + | GREATER => false + + val show = fn precedence' => fn { precedence, string } => + if precedence' <= precedence + then string + else "(" ^ string ^ ")" + end + +structure Prototype = + struct + local + open LongVId + in + val Ident' = hide o Template.Ident + val Module' = hide o Template.Module + end + val $ = valOf o StrId.fromString + val id = fn s => { hasOp = false, data = Module' ($"Test", Ident' ($s)) } + val var = fn s => { hasOp = false, data = Ident' ($s) } + + local + open Ty + in + val Var' = Ty'.hide o Var + val Cons' = Ty'.hide o Cons + val Tuple' = Ty'.hide o Tuple + val Arrow' = Ty'.hide o Arrow + + val Ident' = LongTyCon.hide o LongTyCon.Template.Ident + val Module' = LongTyCon.hide o LongTyCon.Template.Module + + infixr ==> + val op ==> = fn (dom, cod) => Arrow' { dom = dom, cod = cod } + infixr ** + val op ** = fn (ty1, ty2) => Tuple' (ty1, ty2, []) + + val ty = fn s => Module' ($s, Ident' ($"t")) + val dott = fn s => Cons' ([], ty s) + end + + structure PrintTy = + struct + structure Prec = + struct + datatype t = Arrow | Tuple | Atomic + + val eq = op = + val compare = + fn (Arrow , Arrow ) => EQUAL + | (Arrow , _ ) => LESS + | (Tuple , Arrow ) => GREATER + | (Tuple , Tuple ) => EQUAL + | (Tuple , _ ) => LESS + | (Atomic, Arrow ) => GREATER + | (Atomic, Tuple ) => GREATER + | (Atomic, Atomic) => EQUAL + + val zero = Arrow + val succ = + fn Arrow => Tuple + | Tuple => Atomic + | Atomic => Atomic + end + + structure TyPrec = Precedence (Prec) + + val prettyPrint = + Ty'.fold ( + let + open Ty + + val intercalate = fn sep => fn (ty1, ty2, tys) => + Util.format { start = "", stop = "", sep = sep } Fn.id (ty1 :: ty2 :: tys) + in + fn Var tyvar => TyPrec.hide Prec.Atomic (TyVar.toString tyvar) + | Cons (tyseq, longtycon) => + TyPrec.hide Prec.Atomic ( + ( + case tyseq of + nil => "" + | x :: nil => TyPrec.show Prec.Atomic x ^ " " + | x1 :: x2 :: xs => Tuple.toString (TyPrec.show Prec.zero) (x1, x2, xs) ^ " " + ) ^ LongTyCon.toString longtycon + ) + | Record tyrows => TyPrec.hide Prec.Atomic (Util.format { start = "{ ", stop = " }", sep = ", " } (fn (lab, ty) => Util.hasType (Lab.toString lab, TyPrec.show Prec.zero ty)) tyrows) + | Tuple tys => TyPrec.hide Prec.Tuple (intercalate " * " (Seq2.map (TyPrec.show (Prec.succ Prec.Tuple)) tys)) + | Arrow { dom = dom, cod = cod } => TyPrec.hide Prec.Arrow (TyPrec.show (Prec.succ Prec.Arrow) dom ^ " -> " ^ TyPrec.show Prec.Arrow cod) + end + ) + + val ex = + (* Tuple' (Tuple' (dott "Int", dott "String", []), dott "Bool", []) *) + (* Arrow' { dom = Tuple' (dott "Int", dott "String", []), cod = Arrow' { dom = dott "Bool", cod = dott "Real" } } *) + (* dott "List" ==> Tuple' (dott "Int", dott "String", [dott "Foo", dott "Bar" ** dott "Baz", dott "Qux"]) ==> (dott "Bool" ** dott "Real") *) + Cons' ([dott "Int" ** dott "String"], ty "List") ==> Cons' ([dott "Bool"], ty "List") + (* Cons' ([Var' ($"'a"), Cons' ([Var' ($"'b"), Cons' ([], Ident' ($"int"))], ty "Either")], ty "List") *) + end + + local + open Pat + in + val Wildcard' = Pat'.hide Wildcard + val SCon' = Pat'.hide o SCon + val Var' = Pat'.hide o Var + val Unit' = Pat'.hide Unit + val Tuple' = Pat'.hide o Tuple + val List' = Pat'.hide o List + val Constructor' = Pat'.hide o Constructor + val Typed' = Pat'.hide o Typed + end + + structure PrintPat = + struct + structure Prec = + struct + datatype t = Typed | Complex | Atomic + + val eq = op = + val compare = + fn (Typed , Typed ) => EQUAL + | (Typed , _ ) => LESS + | (Complex, Typed ) => GREATER + | (Complex, Complex) => EQUAL + | (Complex, _ ) => LESS + | (Atomic , Typed ) => GREATER + | (Atomic , Complex) => GREATER + | (Atomic , Atomic ) => EQUAL + + val zero = Typed + val succ = + fn Typed => Complex + | Complex => Atomic + | Atomic => Atomic + end + structure Atomic = Precedence (Prec) + + val prettyPrint = + Pat'.fold ( + let + open Pat + in + fn Wildcard => Atomic.hide Prec.Atomic "_" + | SCon scon => Atomic.hide Prec.Atomic (SCon.toString scon) + | Var id => Atomic.hide Prec.Atomic (Op.toString LongVId.toString id) + | Unit => Atomic.hide Prec.Atomic "()" (* TODO: factor out *) + | Tuple pats => Atomic.hide Prec.Atomic (Tuple.toString (Atomic.show Prec.zero) pats) + | List pats => Atomic.hide Prec.Atomic (List.toString (Atomic.show Prec.zero) pats) + | Constructor (id, pat) => Atomic.hide Prec.Complex (Op.toString LongVId.toString id ^ " " ^ Atomic.show Prec.Atomic pat) + | InfixConstructor _ => raise Fail "TODO" + | Typed (pat, ty) => Atomic.hide Prec.Typed (Util.hasType (Atomic.show Prec.Typed pat, PrintTy.TyPrec.show PrintTy.Prec.zero (PrintTy.prettyPrint ty))) + end + ) + + val ex = + Constructor' (id "Qux", + Tuple' ( + Constructor' (id "Foo", + Constructor' (id "Bar", + Tuple' (Var' (var "x"), Unit', [SCon' (SCon.Int 3), Constructor' (id "Baz", Unit')]) + ) + ), + Typed' (Wildcard', dott "Int"), + [List' [Wildcard', Var' (var "y"), Wildcard']] + ) + ) + end + end + +structure Dec = + struct + datatype ('dec, 'exp) t + = Val of TyVar.t Seq.t * (Pat'.t * 'exp) Seq1.t + + fun map (fdec, fexp) = + fn Val (tyvarseq, binds) => Val (tyvarseq, Seq1.map (fn (pat, exp) => (pat, fexp exp)) binds) + end + +structure Exp = + struct + datatype ('dec, 'exp) t + = Var of LongVId.t Op.t + | Unit + | Tuple of 'exp Tuple.t + | List of 'exp list + | Sequence of 'exp Seq2.t + | Typed of 'exp * Ty'.t + + fun map (fdec, fexp) = + fn Var id => Var id + | Unit => Unit + | Tuple exps => Tuple (Tuple.map fexp exps) + | List exps => List (List.map fexp exps) + | Sequence exps => Sequence (Seq2.map fexp exps) + | Typed (exp, ty) => Typed (fexp exp, ty) + end + +structure DecExp' = + ParseTree2 ( + structure Template1 = Dec + structure Template2 = Exp + ) diff --git a/src/sources.cm b/src/sources.cm index 90168ec..8fc8440 100644 --- a/src/sources.cm +++ b/src/sources.cm @@ -1,14 +1,9 @@ Library - signature AUTOFORMAT - structure AutoFormat + source(-) is $SMACKAGE/typeclasses/v1/sources.cm + $SMACKAGE/bananas/v1/sources.cm $/basis.cm - $SMLNJ-LIB/Util/smlnj-lib.cm - $smlnj/compiler/current.cm - $smlnj/viscomp/basics.cm - $smlnj/viscomp/parser.cm - autoformat.sig - autoformat.sml + parse-tree.sml