fix(eo-phi-normalizer): improve parser

eo-phi-normalizer/eo-phi-normalizer.cabal

@@ -394,6 +394,7 @@ extra-source-files:
     test/eo/phi/dataization.yaml
     test/eo/phi/from-eo/as-phi.yaml
     test/eo/phi/metrics.yaml
+    test/eo/phi/parser/expressions.yaml
     test/eo/phi/rewriting.yaml
     test/eo/phi/rules/new.yaml
     test/eo/phi/rules/streams.yaml
@@ -628,6 +629,7 @@ test-suite spec
   main-is: Main.hs
   other-modules:
       Language.EO.Phi.DataizeSpec
+      Language.EO.Phi.ParserSpec
       Language.EO.Phi.RewriteSpec
       Language.EO.PhiSpec
       Language.EO.Rules.PhiPaperSpec

eo-phi-normalizer/grammar/EO/Phi/Syntax.cf

@@ -30,15 +30,15 @@ comment "//" ;
 comment "/*" "*/" ;
 
 token Bytes ({"--"} | ["0123456789ABCDEF"] ["0123456789ABCDEF"] {"-"} | ["0123456789ABCDEF"] ["0123456789ABCDEF"] ({"-"} ["0123456789ABCDEF"] ["0123456789ABCDEF"])+) ;
-token Function upper (char - [" \r\n\t,.|':;!-?][}{)(⟧⟦"])* ;
-token LabelId  lower (char - [" \r\n\t,.|':;!?][}{)(⟧⟦"])* ;
+token Function upper (char - [" \r\n\t,.|':;!-?][}{)(⟧⟦↦"])* ;
+token LabelId  lower (char - [" \r\n\t,.|':;!?][}{)(⟧⟦↦"])* ;
 token AlphaIndex ({"α0"} | {"α"} (digit - ["0"]) (digit)* ) ;
-token LabelMetaId {"!τ"} (char - [" \r\n\t,.|':;!-?][}{)(⟧⟦"])* ;
-token TailMetaId {"!t"} (char - [" \r\n\t,.|':;!-?][}{)(⟧⟦"])* ;
-token BindingsMetaId {"!B"} (char - [" \r\n\t,.|':;!-?][}{)(⟧⟦"])* ;
-token ObjectMetaId {"!b"} (char - [" \r\n\t,.|':;!-?][}{)(⟧⟦"])* ;
-token BytesMetaId {"!y"} (char - [" \r\n\t,.|':;!-?][}{)(⟧⟦"])* ;
-token MetaFunctionName {"@"} (char - [" \r\n\t,.|':;!-?][}{)(⟧⟦"])* ;
+token LabelMetaId {"!τ"} (char - [" \r\n\t,.|':;!-?][}{)(⟧⟦↦"])* ;
+token TailMetaId {"!t"} (char - [" \r\n\t,.|':;!-?][}{)(⟧⟦↦"])* ;
+token BindingsMetaId {"!B"} (char - [" \r\n\t,.|':;!-?][}{)(⟧⟦↦"])* ;
+token ObjectMetaId {"!b"} (char - [" \r\n\t,.|':;!-?][}{)(⟧⟦↦"])* ;
+token BytesMetaId {"!y"} (char - [" \r\n\t,.|':;!-?][}{)(⟧⟦↦"])* ;
+token MetaFunctionName {"@"} (char - [" \r\n\t,.|':;!-?][}{)(⟧⟦↦"])* ;
 token IntegerSigned ('-'? digit+) ;
 token DoubleSigned ('-'? digit+ '.' digit+ ('e' '-'? digit+)?) ;
 token StringRaw '"' ((char - ["\"\\"]) | ('\\' ["\"\\tnrfu"]))* '"';
@@ -71,7 +71,7 @@ internal ConstFloat.    Object ::= Double;
 internal ConstInt.      Object ::= Integer;
 internal ConstString.   Object ::= String;
 
-AlphaBinding.       Binding ::= Attribute "↦" Object ;
+AlphaBinding.       Binding ::= AttributeSugar "↦" Object ;
 AlphaBindingSugar.  Binding ::= Object ;
 EmptyBinding.       Binding ::= Attribute "↦" "∅" ;
 DeltaBinding.       Binding ::= "Δ" "⤍" Bytes ;
@@ -81,14 +81,15 @@ MetaBindings.       Binding ::= BindingsMetaId ;
 MetaDeltaBinding.   Binding ::= "Δ" "⤍" BytesMetaId ;
 separator Binding "," ;
 
+AttributeNoSugar.   AttributeSugar ::= "#" Attribute;
+AttributeSugar.     AttributeSugar ::= "~" LabelId "(" [Attribute] ")";
+separator Attribute ",";
+
 Phi.    Attribute ::= "φ" ;   -- decoratee object
-PhiSugar. Attribute ::= "~" "φ" "(" [LabelId] ")";
 Rho.    Attribute ::= "ρ" ;   -- parent object
 Label.  Attribute ::= LabelId ;
 Alpha.  Attribute ::= AlphaIndex ;
 MetaAttr. Attribute ::= LabelMetaId ;
-AttrSugar. Attribute ::= "~" LabelId "(" [LabelId] ")";
-separator LabelId ",";
 
 -- Additional symbols used as attributes in the rules
 ObjectAttr. RuleAttribute ::= Attribute ;

eo-phi-normalizer/src/Language/EO/Phi/Dataize.hs

@@ -108,7 +108,7 @@ dataizeStepChain mode obj@(Formation bs)
               ctx <- getContext
               return (ctx, AsObject obj')
   | DataizeAll <- mode
-  , Just (AlphaBinding Phi decoratee) <- listToMaybe [b | b@(AlphaBinding Phi _) <- bs]
+  , Just (AlphaBinding' Phi decoratee) <- listToMaybe [b | b@(AlphaBinding' Phi _) <- bs]
   , not hasEmpty = do
       let decoratee' = substThis obj decoratee
       logStep "Dataizing inside phi" (AsObject decoratee')

eo-phi-normalizer/src/Language/EO/Phi/Dataize/Atoms.hs

@@ -163,11 +163,11 @@ knownAtomsList =
          where
           isPackage (LambdaBinding (Function "Package")) = True
           isPackage _ = False
-          dataizeBindingChain (AlphaBinding attr o) = do
+          dataizeBindingChain (AlphaBinding' attr o) = do
             ctx <- getContext
             let extendedContext = (extendContextWith obj ctx){currentAttr = attr}
             dataizationResult <- incLogLevel $ withContext extendedContext $ dataizeRecursivelyChain False o
-            return (AlphaBinding attr (either id (Formation . singleton . DeltaBinding) dataizationResult))
+            return (AlphaBinding' attr (either id (Formation . singleton . DeltaBinding) dataizationResult))
           dataizeBindingChain b = return b
         f name _otherwise = evaluateBuiltinFunChainUnknown name _otherwise
        in

eo-phi-normalizer/src/Language/EO/Phi/Dependencies.hs

@@ -30,7 +30,8 @@ import Language.EO.Phi
 import Control.Monad (foldM)
 
 bindingAttr :: Binding -> Maybe Attribute
-bindingAttr (AlphaBinding a _) = Just a
+bindingAttr (AlphaBinding' a _) = Just a
+bindingAttr b@(AlphaBinding _ _) = errorExpectedDesugaredBinding b
 bindingAttr (EmptyBinding a) = Just a
 bindingAttr (DeltaBinding _) = Just (Alpha (AlphaIndex "Δ"))
 bindingAttr DeltaEmptyBinding = Just (Alpha (AlphaIndex "Δ"))

eo-phi-normalizer/src/Language/EO/Phi/Metrics/Collect.hs

@@ -29,6 +29,7 @@
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -43,6 +44,7 @@ import Data.Maybe (catMaybes)
 import Data.Traversable (forM)
 import Language.EO.Phi.Metrics.Data (BindingMetrics (..), BindingsByPathMetrics (..), MetricsCount, ObjectMetrics (..), Path, ProgramMetrics (..))
 import Language.EO.Phi.Rules.Common ()
+import Language.EO.Phi.Syntax (pattern AlphaBinding')
 import Language.EO.Phi.Syntax.Abs
 
 -- $setup
@@ -180,8 +182,8 @@ getObjectByPath object path =
               x <- bindings
               Right obj <-
                 case x of
-                  AlphaBinding (Alpha (AlphaIndex name)) obj | name == p -> [getObjectByPath obj ps]
-                  AlphaBinding (Label (LabelId name)) obj | name == p -> [getObjectByPath obj ps]
+                  AlphaBinding' (Alpha (AlphaIndex name)) obj | name == p -> [getObjectByPath obj ps]
+                  AlphaBinding' (Label (LabelId name)) obj | name == p -> [getObjectByPath obj ps]
                   _ -> [Left path]
               pure obj
         _ -> Left path
@@ -203,8 +205,8 @@ getBindingsByPathMetrics object path =
           bindingsMetrics = do
             x <- zip bindings objectMetrics
             case x of
-              (AlphaBinding (Alpha (AlphaIndex name)) _, metrics) -> [BindingMetrics{..}]
-              (AlphaBinding (Label (LabelId name)) _, metrics) -> [BindingMetrics{..}]
+              (AlphaBinding' (Alpha (AlphaIndex name)) _, metrics) -> [BindingMetrics{..}]
+              (AlphaBinding' (Label (LabelId name)) _, metrics) -> [BindingMetrics{..}]
               _ -> []
        in Right $ BindingsByPathMetrics{..}
     Right _ -> Left path

eo-phi-normalizer/src/Language/EO/Phi/Preprocess.hs

@@ -22,15 +22,17 @@
 -- SOFTWARE.
 {- FOURMOLU_ENABLE -}
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Language.EO.Phi.Preprocess where
 
 import Control.Monad (void)
 import Data.Void (Void)
+import Language.EO.Phi.Syntax.Abs
 import Replace.Megaparsec (splitCap)
-import Text.Megaparsec (MonadParsec (..), Parsec, Stream (..), between, match, sepBy)
+import Text.Megaparsec (MonadParsec (..), Parsec, Stream (..), between, choice, match, oneOf, optional, sepBy)
 import Text.Megaparsec.Byte.Lexer qualified as L
-import Text.Megaparsec.Char (lowerChar, space)
+import Text.Megaparsec.Char (space, string)
 
 symbol :: String -> Parser String
 symbol = L.symbol space
@@ -40,41 +42,96 @@ lexeme = L.lexeme space
 
 type Parser = Parsec Void String
 
-parseLabelId :: Parser ()
+parseTail :: Parser String
+parseTail = takeWhileP (Just "LabelId") (`notElem` " \r\n\t,.|':;!?][}{)(⟧⟦↦")
+
+parseLabelId :: Parser LabelId
 parseLabelId = lexeme do
-  void lowerChar
-  void $ takeWhileP (Just "LabelId") (`notElem` " \r\n\t,.|':;!?][}{)(⟧⟦")
+  l <- oneOf ['a' .. 'z']
+  ls <- parseTail
+  pure $ LabelId (l : ls)
+
+parseToken :: String -> (String -> a) -> Parser a
+parseToken prefix cons = lexeme do
+  void $ string prefix
+  ls <- parseTail
+  pure $ cons (prefix <> ls)
+
+parseObjectMetaId :: Parser ObjectMetaId
+parseObjectMetaId = parseToken "!b" ObjectMetaId
+
+parseBytesMetaId :: Parser BytesMetaId
+parseBytesMetaId = parseToken "!y" BytesMetaId
+
+parseLabelMetaId :: Parser LabelMetaId
+parseLabelMetaId = parseToken "!τ" LabelMetaId
+
+parseMetaId :: Parser MetaId
+parseMetaId =
+  choice
+    [ MetaIdObject <$> parseObjectMetaId
+    , MetaIdBytes <$> parseBytesMetaId
+    , MetaIdLabel <$> parseLabelMetaId
+    ]
+
+parseAlphaIndex :: Parser AlphaIndex
+parseAlphaIndex = parseToken "α" AlphaIndex
+
+parseAttribute :: Parser Attribute
+parseAttribute = lexeme do
+  choice
+    [ Phi <$ symbol "φ"
+    , Rho <$ symbol "ρ"
+    , Label <$> parseLabelId
+    , Alpha <$> parseAlphaIndex
+    ]
 
 parseBindingArrow :: Parser ()
 parseBindingArrow = void $ symbol "↦"
 
-parseAlphaAttr :: Parser ()
-parseAlphaAttr = do
-  void parseLabelId
-  void $ between (symbol "(") (symbol ")") (sepBy parseLabelId (symbol ","))
-
-parseAlphaBindingSugar :: Parser ()
+parseAttributeSugar :: Parser AttributeSugar
+parseAttributeSugar = do
+  choice
+    [ do
+        labelId <- parseLabelId
+        attrs <- optional $ between (symbol "(") (symbol ")") (sepBy parseAttribute (symbol ","))
+        case attrs of
+          Nothing -> pure $ AttributeNoSugar (Label labelId)
+          Just attrs' -> pure $ AttributeSugar labelId attrs'
+    , AttributeNoSugar <$> parseAttribute
+    ]
+
+type Attr = Either MetaId AttributeSugar
+
+parseAlphaBindingSugar :: Parser Attr
 parseAlphaBindingSugar = do
-  parseAlphaAttr
+  attr <-
+    choice
+      [ Left <$> parseMetaId
+      , Right <$> parseAttributeSugar
+      ]
   parseBindingArrow
+  notFollowedBy (symbol "∅")
+  pure attr
 
-splitInput :: Parser a -> String -> [Either String (Tokens [Char])]
-splitInput sep = splitCap (fst <$> match sep)
+splitInput :: Parser a -> String -> [Either String (Tokens [Char], a)]
+splitInput sep = splitCap (match sep)
 
-addPrefix :: Parser a -> String -> [String]
-addPrefix sep = map (either id ("~" <>)) . splitInput sep
+addPrefix :: Parser Attr -> String -> [String]
+addPrefix sep = fmap (either id (\(x, a) -> choosePrefix a <> x)) . splitInput sep
+ where
+  choosePrefix = \case
+    Right AttributeSugar{} -> "~"
+    _ -> "#"
 
-preprocess' :: Parser a -> String -> String
+preprocess' :: Parser Attr -> String -> String
 preprocess' sep = concat . addPrefix sep
 
 preprocess :: String -> String
 preprocess = preprocess' parseAlphaBindingSugar
 
 input1 :: String
-input1 = "{⟦ org ↦ ⟦ eolang ↦ ⟦ number( as-bytes, abra  ) ↦ ⟦ φ ↦ ξ.as-bytes, neg ↦ ξ.times(-1), ⟧, λ ⤍ Package ⟧, λ ⤍ Package ⟧ ⟧}"
-
--- >>> addPrefix parseAlphaBindingSugar input1
--- ["{\10214 org \8614 \10214 eolang \8614 \10214 ","~number( as-bytes, abra  ) \8614 ","\10214 \966 \8614 \958.as-bytes, neg \8614 \958.times(-1), \10215, \955 \10509 Package \10215, \955 \10509 Package \10215 \10215}"]
+input1 = "{⟦ org ↦ ⟦ ⟧(α0 ↦ !b1) ⟧}"
 
 -- >>> preprocess input1
--- "{\10214 org \8614 \10214 eolang \8614 \10214 ~number( as-bytes, abra  ) \8614 \10214 \966 \8614 \958.as-bytes, neg \8614 \958.times(-1), \10215, \955 \10509 Package \10215, \955 \10509 Package \10215 \10215}"
+-- "{\10214 #org \8614 \10214 \10215(#\945\&0 \8614 !b1) \10215}"

eo-phi-normalizer/src/Language/EO/Phi/Pretty.hs

@@ -126,6 +126,11 @@ instance Pretty Abs.Binding where
     Abs.MetaBindings bindingsmetaid -> pretty bindingsmetaid
     Abs.MetaDeltaBinding bytesmetaid -> pretty "Δ ⤍" <+> pretty bytesmetaid
 
+instance Pretty Abs.AttributeSugar where
+  pretty = \case
+    Abs.AttributeSugar labelid labelids -> pretty labelid <> lparen <> pretty labelids <> rparen
+    Abs.AttributeNoSugar attribute -> pretty attribute
+
 instance {-# OVERLAPPING #-} Pretty [Abs.Binding] where
   pretty = vsep . punctuate comma . fmap pretty
 
@@ -136,8 +141,6 @@ instance Pretty Abs.Attribute where
     Abs.Label labelid -> pretty labelid
     Abs.Alpha alphaindex -> pretty alphaindex
     Abs.MetaAttr labelmetaid -> pretty labelmetaid
-    Abs.AttrSugar labelid labelids -> pretty labelid <> lparen <> pretty labelids <> rparen
-    Abs.PhiSugar labelids -> pretty Abs.Phi <> lparen <> pretty labelids <> rparen
 
 instance {-# OVERLAPPING #-} Pretty [Abs.LabelId] where
   pretty = hsep . punctuate comma . fmap pretty

eo-phi-normalizer/src/Language/EO/Phi/Rules/Common.hs

@@ -27,6 +27,7 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
@@ -40,7 +41,22 @@ import Data.HashMap.Strict qualified as HashMap
 import Data.List (minimumBy, nubBy, sortOn)
 import Data.List.NonEmpty (NonEmpty (..), (<|))
 import Data.Ord (comparing)
-import Language.EO.Phi.Syntax
+import Language.EO.Phi.Syntax (
+  Attribute (..),
+  Binding (..),
+  BindingsMetaId (BindingsMetaId),
+  Bytes,
+  LabelId (LabelId),
+  LabelMetaId (LabelMetaId),
+  Object (..),
+  Program (..),
+  desugar,
+  errorExpectedDesugaredBinding,
+  errorExpectedDesugaredObject,
+  printTree,
+  pattern AlphaBinding',
+  pattern AlphaBinding'',
+ )
 
 -- $setup
 -- >>> :set -XOverloadedStrings
@@ -145,7 +161,7 @@ propagateName2 f (name, obj) bs = (name, f obj bs)
 
 withSubObjectBindings :: (Context -> Object -> [(String, Object)]) -> Context -> [Binding] -> [(String, [Binding])]
 withSubObjectBindings _ _ [] = []
-withSubObjectBindings f ctx (b@(AlphaBinding Rho _) : bs) =
+withSubObjectBindings f ctx (b@(AlphaBinding' Rho _) : bs) =
   -- do not apply rules inside ρ-bindings
   [(name, b : bs') | (name, bs') <- withSubObjectBindings f ctx bs]
 withSubObjectBindings f ctx (b : bs) =
@@ -156,7 +172,8 @@ withSubObjectBindings f ctx (b : bs) =
 
 withSubObjectBinding :: (Context -> Object -> [(String, Object)]) -> Context -> Binding -> [(String, Binding)]
 withSubObjectBinding f ctx = \case
-  AlphaBinding a obj -> propagateName1 (AlphaBinding a) <$> withSubObject f (ctx{currentAttr = a}) obj
+  AlphaBinding' a obj -> propagateName1 (AlphaBinding' a) <$> withSubObject f (ctx{currentAttr = a}) obj
+  b@AlphaBinding{} -> errorExpectedDesugaredBinding b
   b@AlphaBindingSugar{} -> errorExpectedDesugaredBinding b
   EmptyBinding{} -> []
   DeltaBinding{} -> []
@@ -258,7 +275,8 @@ equalObjectNamed x y = snd x `equalObject` snd y
 equalBindings :: [Binding] -> [Binding] -> Bool
 equalBindings bindings1 bindings2 = and (zipWith equalBinding (sortOn attr bindings1) (sortOn attr bindings2))
  where
-  attr (AlphaBinding a _) = a
+  attr (AlphaBinding' a _) = a
+  attr b@(AlphaBinding''{}) = errorExpectedDesugaredBinding b
   attr (EmptyBinding a) = a
   attr (DeltaBinding _) = Label (LabelId "Δ")
   attr DeltaEmptyBinding = Label (LabelId "Δ")
@@ -396,9 +414,10 @@ applyRulesChainWith limits@ApplicationLimits{..} obj
 -- | Lookup a binding by the attribute name.
 lookupBinding :: Attribute -> [Binding] -> Maybe Object
 lookupBinding _ [] = Nothing
-lookupBinding a (AlphaBinding a' object : bindings)
+lookupBinding a (AlphaBinding' a' object : bindings)
   | a == a' = Just object
   | otherwise = lookupBinding a bindings
+lookupBinding _ (b@(AlphaBinding''{}) : _) = errorExpectedDesugaredBinding b
 lookupBinding a (_ : bindings) = lookupBinding a bindings
 
 objectBindings :: Object -> [Binding]
@@ -408,7 +427,7 @@ objectBindings (ObjectDispatch obj _attr) = objectBindings obj
 objectBindings _ = []
 
 isRhoBinding :: Binding -> Bool
-isRhoBinding (AlphaBinding Rho _) = True
+isRhoBinding (AlphaBinding' Rho _) = True
 isRhoBinding _ = False
 
 hideRhoInBinding :: Binding -> Binding