Allow setting precedence of dotted identifiers (.longvid.) via infix …

…declarations
minoki · Dec 11, 2023 · df2c9c1 · df2c9c1
1 parent 722bd35
commit df2c9c1
Show file tree

Hide file tree

Showing 12 changed files with 125 additions and 28 deletions.
diff --git a/doc/Extensions.md b/doc/Extensions.md
@@ -79,13 +79,25 @@ end
 
 `pat_1 .longvid. pat_2` is equivalent to `op longvid (pat_1, pat_2)`.
 
-Associativity of `.longvid.` is currently `infix 0`, but I plan to allow overriding.
+Associativity of `.strid1...stridN.vid.` can be controlled by `infix(r) <prec> .vid.` declaration.
+If no such declaration is found, `infix 0` is assumed.
 
 Examples:
 
 ```sml
 0wxdead .Word.andb. 0wxbeef; (* equivalent to Word.andb (0wxdead, 0wxbeef) *)
 fun a .foo. b = print (a ^ ", " ^ b ^ "\n"); (* equivalent to fun foo (a, b) = ... *)
+infix 7 .*.
+infix 6 .+.
+val x = 1 .Int.*. 2 .Int.+. 3 .Int.*. 4 (* equivalent to Int.+ (Int.* (1, 2), Int.* (3, 4)) *)
+```
+
+The standard library `$(SML_LIB)/basis/basis.mlb` contains the following declarations:
+
+```sml
+infix 7 .*. ./. .div. .mod. .quot. .rem.
+infix 6 .+. .-. .^.
+infix 4 .>. .>=. .<. .<=. .==. .!=. .?=.
 ```
 
 ## Value description in comments

diff --git a/lib/lunarml/ml/basis/infixes.sml b/lib/lunarml/ml/basis/infixes.sml
@@ -4,3 +4,8 @@ infixr 5  :: @
 infix  4  = <> > >= < <=
 infix  3  := o
 infix  0  before
+
+(* extension *)
+infix  7  .*. ./. .div. .mod. .quot. .rem.
+infix  6  .+. .-. .^.
+infix  4  .>. .>=. .<. .<=. .==. .!=. .?=.
diff --git a/lib/lunarml/ml/basis/lunarml-prim.mlb b/lib/lunarml/ml/basis/lunarml-prim.mlb
@@ -1,4 +1,6 @@
+ann "allowInfixingDot true" in
 infixes.sml
+end
 _prim
 _primOverloads
 ann "allowPrim true" "allowBindEqual true" "allowOverload true" in

diff --git a/src/initialenv.sml b/src/initialenv.sml
@@ -10,6 +10,7 @@ val initialFixityEnv : Fixity.Env = let fun mkValConMap xs = List.foldl (fn (n,
                                         val refConMap = mkValConMap ["ref"]
                                         val listConMap = mkValConMap ["nil", "::"]
                                     in { fixityMap = Syntax.VIdMap.empty
+                                       , dottedFixityMap = Syntax.VIdMap.empty
                                        , idStatusMap = { valMap = List.foldl (Syntax.VIdMap.unionWith #2) (mkExConMap ["Match", "Bind", "Div", "Overflow", "Size", "Subscript", "Fail", "_Prim.Lua.Error"]) [boolConMap, refConMap, listConMap]
                                                        , tyConMap = mkTyConMap [("bool", boolConMap)
                                                                                ,("ref", refConMap)

diff --git a/src/postparsing.sml b/src/postparsing.sml
@@ -20,6 +20,7 @@ withtype IdStatusMap = { valMap : (unit Syntax.IdStatus) Syntax.VIdMap.map
                        , strMap : IdStatusMap' Syntax.StrIdMap.map
                        }
 type Env = { fixityMap : FixityStatusMap
+           , dottedFixityMap : Syntax.InfixAssociativity Syntax.VIdMap.map
            , idStatusMap : IdStatusMap
            , sigMap : IdStatusMap Syntax.SigIdMap.map
            , funMap : IdStatusMap Syntax.FunIdMap.map
@@ -31,25 +32,30 @@ val emptyIdStatusMap : IdStatusMap = { valMap = Syntax.VIdMap.empty
                                      }
 
 val emptyEnv : Env = { fixityMap = Syntax.VIdMap.empty
+                     , dottedFixityMap = Syntax.VIdMap.empty
                      , idStatusMap = emptyIdStatusMap
                      , sigMap = Syntax.SigIdMap.empty
                      , funMap = Syntax.FunIdMap.empty
                      }
 
 (* used by fixity declaration *)
-fun envWithFixityMap fixityMap : Env = { fixityMap = fixityMap
-                                       , idStatusMap = emptyIdStatusMap
-                                       , sigMap = Syntax.SigIdMap.empty
-                                       , funMap = Syntax.FunIdMap.empty
-                                       }
+fun envWithFixityMap (fixityMap, dottedFixityMap) : Env
+    = { fixityMap = fixityMap
+      , dottedFixityMap = dottedFixityMap
+      , idStatusMap = emptyIdStatusMap
+      , sigMap = Syntax.SigIdMap.empty
+      , funMap = Syntax.FunIdMap.empty
+      }
 
 fun envWithIdStatusMap idStatusMap : Env = { fixityMap = Syntax.VIdMap.empty
+                                           , dottedFixityMap = Syntax.VIdMap.empty
                                            , idStatusMap = idStatusMap
                                            , sigMap = Syntax.SigIdMap.empty
                                            , funMap = Syntax.FunIdMap.empty
                                            }
 
 fun envWithStrMap strMap : Env = { fixityMap = Syntax.VIdMap.empty
+                                 , dottedFixityMap = Syntax.VIdMap.empty
                                  , idStatusMap = { valMap = Syntax.VIdMap.empty
                                                  , tyConMap = Syntax.TyConMap.empty
                                                  , strMap = strMap
@@ -60,12 +66,14 @@ fun envWithStrMap strMap : Env = { fixityMap = Syntax.VIdMap.empty
 
 (* used by signature binding *)
 fun envWithSigMap sigMap : Env = { fixityMap = Syntax.VIdMap.empty
+                                 , dottedFixityMap = Syntax.VIdMap.empty
                                  , idStatusMap = emptyIdStatusMap
                                  , sigMap = sigMap
                                  , funMap = Syntax.FunIdMap.empty
                                  }
 
 fun envWithFunMap funMap : Env = { fixityMap = Syntax.VIdMap.empty
+                                 , dottedFixityMap = Syntax.VIdMap.empty
                                  , idStatusMap = emptyIdStatusMap
                                  , sigMap = Syntax.SigIdMap.empty
                                  , funMap = funMap
@@ -79,6 +87,7 @@ fun mergeIdStatusMap(env1 : IdStatusMap, env2 : IdStatusMap) : IdStatusMap
 
 fun mergeEnv(env1 : Env, env2 : Env) : Env
     = { fixityMap = Syntax.VIdMap.unionWith #2 (#fixityMap env1, #fixityMap env2)
+      , dottedFixityMap = Syntax.VIdMap.unionWith #2 (#dottedFixityMap env1, #dottedFixityMap env2)
       , idStatusMap = mergeIdStatusMap(#idStatusMap env1, #idStatusMap env2)
       , sigMap = Syntax.SigIdMap.unionWith #2 (#sigMap env1, #sigMap env2)
       , funMap = Syntax.FunIdMap.unionWith #2 (#funMap env1, #funMap env2)
@@ -89,6 +98,11 @@ fun getFixityStatus ({ fixityMap, ... } : Env, vid)
           SOME a => a
         | NONE => Syntax.Nonfix
 
+fun getDottedFixityStatus ({ dottedFixityMap, ... } : Env, vid)
+    = case Syntax.VIdMap.find (dottedFixityMap, vid) of
+          SOME a => a
+        | NONE => Syntax.LeftAssoc 0
+
 fun isConstructor ({ idStatusMap = { valMap, ... }, ... } : Env, vid)
     = case Syntax.VIdMap.find (valMap, vid) of
           SOME (Syntax.ValueConstructor _) => true
@@ -212,8 +226,8 @@ fun doPat(ctx, env : Env, UnfixedSyntax.WildcardPat span) = Syntax.WildcardPat s
                                       )
                    | Syntax.Infix assoc => emitError(ctx, [span1], "infix operator used in prefix position")
                 )
-            | doPrefix (atpat :: UnfixedSyntax.InfixPat (span2, longvid) :: pats)
-              = let val assoc = Syntax.LeftAssoc 0
+            | doPrefix (atpat :: UnfixedSyntax.InfixPat (span2, longvid as Syntax.MkQualified (_, shortvid)) :: pats)
+              = let val assoc = getDottedFixityStatus (env, shortvid)
                 in Tree (doPat (ctx, env, atpat), assoc, span2, longvid, doPrefix pats)
                 end
             | doPrefix(UnfixedSyntax.InfixOrVIdPat(span1, vid) :: atpat :: pats)
@@ -243,8 +257,8 @@ fun doPat(ctx, env : Env, UnfixedSyntax.WildcardPat span) = Syntax.WildcardPat s
                      Syntax.Nonfix => emitError(ctx, [SourcePos.mergeSpan(Syntax.getSourceSpanOfPat lhs, span2)], "invalid pattern")
                    | Syntax.Infix assoc => Tree (lhs, assoc, span2, Syntax.MkQualified ([], vid), doPrefix pats)
                 )
-            | doInfix (lhs : Syntax.Pat, UnfixedSyntax.InfixPat (span2, longvid) :: pats)
-              = let val assoc = Syntax.LeftAssoc 0 (* TODO: Allow setting *)
+            | doInfix (lhs : Syntax.Pat, UnfixedSyntax.InfixPat (span2, longvid as Syntax.MkQualified (_, shortvid)) :: pats)
+              = let val assoc = getDottedFixityStatus (env, shortvid)
                 in Tree (lhs, assoc, span2, longvid, doPrefix pats)
                 end
             | doInfix(lhs, nil) = Leaf lhs
@@ -350,8 +364,8 @@ fun doExp(ctx, env, UnfixedSyntax.SConExp(span, scon)) = Syntax.SConExp(span, sc
                      Syntax.Nonfix => doInfix(Syntax.AppExp(SourcePos.mergeSpan(Syntax.getSourceSpanOfExp lhs, span2), lhs, Syntax.VarExp(span2, Syntax.MkLongVId([], vid))), rest)
                    | Syntax.Infix assoc => Tree (lhs, assoc, span2, Syntax.MkQualified ([], vid), doPrefix rest)
                 )
-            | doInfix (lhs : Syntax.Exp, UnfixedSyntax.InfixExp (span2, longvid) :: rest)
-              = let val assoc = Syntax.LeftAssoc 0 (* TODO: Allow setting *)
+            | doInfix (lhs : Syntax.Exp, UnfixedSyntax.InfixExp (span2, longvid as Syntax.MkQualified (_, shortvid)) :: rest)
+              = let val assoc = getDottedFixityStatus (env, shortvid)
                 in Tree (lhs, assoc, span2, longvid, doPrefix rest)
                 end
             | doInfix(lhs, x :: rest) = let val x' = doExp(ctx, env, x)
@@ -500,9 +514,18 @@ and doDec (ctx, env, UnfixedSyntax.ValDec (span, tyvars, desc, valbind)) = (empt
                                                                                             ) emptyIdStatusMap strids
                                                            in (envWithIdStatusMap idStatusMap, [Syntax.OpenDec(span, strids)])
                                                            end
-  | doDec(ctx, env, UnfixedSyntax.FixityDec(span, fixity, vids)) = let val fixityMap = List.foldl (fn (vid, m) => Syntax.VIdMap.insert(m, vid, fixity)) Syntax.VIdMap.empty vids
-                                                                   in (envWithFixityMap fixityMap, [])
-                                                                   end
+  | doDec (ctx, env, UnfixedSyntax.FixityDec (span, fixity as Syntax.Infix assoc, vids))
+    = let val fixityMaps = List.foldl (fn (Syntax.ShortVId vid, (m, n)) => (Syntax.VIdMap.insert (m, vid, fixity), n)
+                                      | (Syntax.InfixVId vid, (m, n)) => (m, Syntax.VIdMap.insert (n, Syntax.MkVId vid, assoc))
+                                      ) (Syntax.VIdMap.empty, Syntax.VIdMap.empty) vids
+      in (envWithFixityMap fixityMaps, [])
+      end
+  | doDec (ctx, env, UnfixedSyntax.FixityDec (span, fixity as Syntax.Nonfix, vids))
+    = let val fixityMap = List.foldl (fn (Syntax.ShortVId vid, m) => Syntax.VIdMap.insert (m, vid, fixity)
+                                     | (Syntax.InfixVId vid, m) => (emitNonfatalError (ctx, [span], "invalid nonfix declaration for dotted identifier"); m)
+                                     ) Syntax.VIdMap.empty vids
+      in (envWithFixityMap (fixityMap, Syntax.VIdMap.empty), [])
+      end
   | doDec (ctx, env, UnfixedSyntax.DoDec (span, exp)) = ( if #allowDoDecls (#languageOptions ctx) then
                                                               ()
                                                           else

diff --git a/src/syntax.grm b/src/syntax.grm
@@ -43,7 +43,8 @@ fun span(p1,p2) = { start = p1, end_ = p2 }
     | SymbolicIdent of string
     | QualifiedSymbolicIdent of string list * string
     | DotSymbolicIdent of string (* identifier with leading dot (may be used by future extension) *)
-    | InfixIdent of string list * string (* identifier with prefix and postfix dots (extension) *)
+    | InfixIdent of string (* identifier with prefix and postfix dots (extension) *)
+    | QualifiedInfixIdent of string list * string (* identifier with prefix and postfix dots (extension) *)
     | PrimIdent of string (* identifiers prefixed by "_Prim." (extension) *)
     | PosInt of IntInf.int (* positive integer literal, not starting with 0, and not containing any underscore *)
     | ZNIntConst of IntInf.int (* starting with 0, or negative integer literal, or contains an underscore *)
@@ -154,7 +155,7 @@ fun span(p1,p2) = { start = p1, end_ = p2 }
        | Dec of UnfixedSyntax.Dec
        | Decs of UnfixedSyntax.Dec list
        | LongStrIds of Syntax.LongStrId list
-       | VIds of Syntax.VId list
+       | VIds of Syntax.ShortOrInfixVId list
        | ValBind of UnfixedSyntax.ValBind list
        | FValBind of UnfixedSyntax.FValBind list
        | FMatch of UnfixedSyntax.FMRule list
@@ -334,7 +335,8 @@ AtPat : UNDERSCORE (UnfixedSyntax.WildcardPat(span(UNDERSCOREleft,UNDERSCORErigh
 (* one or more atomic patterns *)
 AtPats : AtPat ([AtPat])
        | AtPat AtPats (AtPat :: AtPats)
-       | AtPat InfixIdent AtPats (AtPat :: UnfixedSyntax.InfixPat (span (InfixIdentleft, InfixIdentright), Syntax.MkQualified (List.map Syntax.MkStrId (#1 InfixIdent), Syntax.MkVId (#2 InfixIdent))) :: AtPats)
+       | AtPat InfixIdent AtPats (AtPat :: UnfixedSyntax.InfixPat (span (InfixIdentleft, InfixIdentright), Syntax.MkQualified ([], Syntax.MkVId InfixIdent)) :: AtPats)
+       | AtPat QualifiedInfixIdent AtPats (AtPat :: UnfixedSyntax.InfixPat (span (QualifiedInfixIdentleft, QualifiedInfixIdentright), Syntax.MkQualified (List.map Syntax.MkStrId (#1 QualifiedInfixIdent), Syntax.MkVId (#2 QualifiedInfixIdent))) :: AtPats)
 
 TypedPat : AtPats (UnfixedSyntax.JuxtapositionPat(span(AtPatsleft, AtPatsright), AtPats))
          | TypedPat COLON Ty (UnfixedSyntax.TypedPat (span(TypedPatleft, Tyright), TypedPat, Ty)) (* typed *)
@@ -478,7 +480,8 @@ InfExp : AppExp
 
 AppOrInfExp : AtExp AppOrInfExp (AtExp :: AppOrInfExp) (* atomic *)
             | AtExp ([AtExp])
-            | AtExp InfixIdent AppOrInfExp (AtExp :: UnfixedSyntax.InfixExp (span (InfixIdentleft, InfixIdentright), Syntax.MkQualified (List.map Syntax.MkStrId (#1 InfixIdent), Syntax.MkVId (#2 InfixIdent))) :: AppOrInfExp)
+            | AtExp InfixIdent AppOrInfExp (AtExp :: UnfixedSyntax.InfixExp (span (InfixIdentleft, InfixIdentright), Syntax.MkQualified ([], Syntax.MkVId InfixIdent)) :: AppOrInfExp)
+            | AtExp QualifiedInfixIdent AppOrInfExp (AtExp :: UnfixedSyntax.InfixExp (span (QualifiedInfixIdentleft, QualifiedInfixIdentright), Syntax.MkQualified (List.map Syntax.MkStrId (#1 QualifiedInfixIdent), Syntax.MkVId (#2 QualifiedInfixIdent))) :: AppOrInfExp)
 
 TypedExp : AppOrInfExp (UnfixedSyntax.JuxtapositionExp(span(AppOrInfExpleft,AppOrInfExpright), AppOrInfExp))
          | TypedExp COLON Ty (UnfixedSyntax.TypedExp (span(TypedExpleft,Tyright), TypedExp, Ty)) (* typed (L) *)
@@ -616,8 +619,10 @@ LongStrIds : LongStrId LongStrIds (LongStrId :: LongStrIds)
            | LongStrId (LongStrId :: nil)
 
 (* VId[1] ... VId[n] *)
-VIds : VId VIds (VId :: VIds)
-     | VId (VId :: nil)
+VIds : VId VIds (Syntax.ShortVId VId :: VIds)
+     | InfixIdent VIds (Syntax.InfixVId InfixIdent :: VIds)
+     | VId (Syntax.ShortVId VId :: nil)
+     | InfixIdent (Syntax.InfixVId InfixIdent :: nil)
 
 (* value bindings *)
 ValBind : Pat EQUALS Exp AND ValBind (UnfixedSyntax.PatBind (span(Patleft, ValBindright), Pat, Exp) :: ValBind)

diff --git a/src/syntax.sml b/src/syntax.sml
@@ -25,6 +25,9 @@ fun MkLongVId(strids, vid: VId) = MkQualified(strids, vid)
 fun MkLongTyCon(strids, tycon: TyCon) = MkQualified(strids, tycon)
 fun MkLongStrId(strids, strid: StrId) = MkQualified(strids, strid)
 
+datatype ShortOrInfixVId = ShortVId of VId
+                         | InfixVId of string
+
 fun getVIdName(MkVId name) = name
   | getVIdName(GeneratedVId (name, i)) = name ^ "@" ^ Int.toString i
 
@@ -531,7 +534,7 @@ datatype Exp = SConExp of SourcePos.span * Syntax.SCon (* special constant *)
              | ExceptionDec of SourcePos.span * Syntax.ExBind list
              | LocalDec of SourcePos.span * Dec list * Dec list
              | OpenDec of SourcePos.span * Syntax.LongStrId list
-             | FixityDec of SourcePos.span * Syntax.FixityStatus * Syntax.VId list
+             | FixityDec of SourcePos.span * Syntax.FixityStatus * Syntax.ShortOrInfixVId list
              | DoDec of SourcePos.span * Exp (* [Successor ML] do declaration *)
              | OverloadDec of SourcePos.span * string * Syntax.LongTyCon * (string * Exp) list
              | EqualityDec of SourcePos.span * Syntax.TyVar list * Syntax.LongTyCon * Exp