feat(eo-phi-normalizer): support custom strings

objectionary · Dec 27, 2024 · 7ecda29 · 7ecda29
1 parent 49756fb
commit 7ecda29
Show file tree

Hide file tree

Showing 14 changed files with 72 additions and 7 deletions.
diff --git a/eo-phi-normalizer/app/Main.hs b/eo-phi-normalizer/app/Main.hs
@@ -569,6 +569,7 @@ wrapRawBytesIn = \case
   obj@MetaTailContext{} -> obj
   obj@MetaFunction{} -> obj
   obj@ConstString{} -> wrapRawBytesIn (desugar obj)
+  obj@ConstStringRaw{} -> errorExpectedDesugaredObject obj
   obj@ConstInt{} -> wrapRawBytesIn (desugar obj)
   obj@ConstIntRaw{} -> errorExpectedDesugaredObject obj
   obj@ConstFloat{} -> wrapRawBytesIn (desugar obj)

diff --git a/eo-phi-normalizer/grammar/EO/Phi/Syntax.cf b/eo-phi-normalizer/grammar/EO/Phi/Syntax.cf
@@ -41,6 +41,7 @@ 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"]))* '"';
 
 Program. Program ::= "{" "⟦" [Binding] "⟧" "}" ;
 
@@ -57,7 +58,7 @@ GlobalObject.       Object ::= "Φ";
 GlobalObjectPhiOrg. Object ::= "Φ̇";
 ThisObject.         Object ::= "ξ";
 Termination.        Object ::= "⊥" ;
-ConstString.        Object ::= String ;
+ConstStringRaw.     Object ::= StringRaw ;
 ConstIntRaw.        Object ::= IntegerSigned ;
 ConstFloatRaw.      Object ::= DoubleSigned ;
 MetaSubstThis.      Object ::= Object "[" "ξ" "↦" Object "]" ;
@@ -66,8 +67,9 @@ MetaObject.         Object ::= ObjectMetaId ;
 MetaTailContext.    Object ::= Object "*" TailMetaId ;
 MetaFunction.       Object ::= MetaFunctionName "(" Object ")" ;
 
-internal ConstFloat. Object ::= Double;
-internal ConstInt.   Object ::= Integer;
+internal ConstFloat.    Object ::= Double;
+internal ConstInt.      Object ::= Integer;
+internal ConstString.   Object ::= String;
 
 AlphaBinding.       Binding ::= Attribute "↦" Object ;
 AlphaBindingSugar.  Binding ::= Object ;

diff --git a/eo-phi-normalizer/src/Language/EO/Phi/Normalize.hs b/eo-phi-normalizer/src/Language/EO/Phi/Normalize.hs
@@ -80,6 +80,7 @@ peelObject = \case
   MetaSubstThis{} -> error "impossible"
   MetaContextualize{} -> error "impossible"
   obj@ConstString{} -> peelObject (desugar obj)
+  obj@ConstStringRaw{} -> errorExpectedDesugaredObject obj
   obj@ConstInt{} -> peelObject (desugar obj)
   obj@ConstIntRaw{} -> errorExpectedDesugaredObject obj
   obj@ConstFloat{} -> peelObject (desugar obj)

diff --git a/eo-phi-normalizer/src/Language/EO/Phi/Pretty.hs b/eo-phi-normalizer/src/Language/EO/Phi/Pretty.hs
@@ -68,6 +68,9 @@ instance Pretty Abs.IntegerSigned where
 instance Pretty Abs.DoubleSigned where
   pretty (Abs.DoubleSigned i) = pretty i
 
+instance Pretty Abs.StringRaw where
+  pretty (Abs.StringRaw i) = pretty i
+
 instance Pretty Abs.Program where
   pretty = \case
     Abs.Program bindings ->
@@ -100,7 +103,8 @@ instance Pretty Abs.Object where
     Abs.GlobalObjectPhiOrg -> pretty "Φ̇"
     Abs.ThisObject -> pretty "ξ"
     Abs.Termination -> pretty "⊥"
-    Abs.ConstString str -> pretty (show str)
+    Abs.ConstStringRaw str -> pretty str
+    Abs.ConstString str -> pretty str
     Abs.ConstIntRaw integersigned -> pretty integersigned
     Abs.ConstFloatRaw doublesigned -> pretty doublesigned
     Abs.MetaSubstThis object1 object2 -> pretty object1 <+> lbracket <+> pretty "ξ ↦" <+> pretty object2 <+> rbracket
@@ -134,6 +138,11 @@ instance Pretty Abs.Attribute where
     Abs.MetaAttr labelmetaid -> pretty labelmetaid
     Abs.AttrSugar labelid labelids -> pretty labelid <> lparen <> pretty labelids <> rparen
 
+-- instance {-# OVERLAPPING #-} Pretty AttributeSugar where
+--   pretty = \case
+--     (Abs.AttrSugar labelid labelids) -> pretty labelid <> lparen <> pretty labelids <> rparen
+--     (Abs.AttrNormal labelid) -> pretty labelid
+
 instance {-# OVERLAPPING #-} Pretty [Abs.LabelId] where
   pretty = hsep . punctuate comma . fmap pretty
 

diff --git a/eo-phi-normalizer/src/Language/EO/Phi/Rules/Common.hs b/eo-phi-normalizer/src/Language/EO/Phi/Rules/Common.hs
@@ -127,6 +127,7 @@ withSubObject f ctx root =
     MetaSubstThis _ _ -> []
     MetaContextualize _ _ -> []
     ConstString{} -> []
+    obj@ConstStringRaw{} -> errorExpectedDesugaredObject obj
     ConstInt{} -> []
     obj@ConstIntRaw{} -> errorExpectedDesugaredObject obj
     ConstFloat{} -> []
@@ -206,6 +207,7 @@ objectSize = \case
   obj@MetaContextualize{} -> error ("impossible: expected a desugared object, but got: " <> printTree obj)
   obj@MetaTailContext{} -> error ("impossible: expected a desugared object, but got: " <> printTree obj)
   obj@ConstString{} -> objectSize (desugar obj)
+  obj@ConstStringRaw{} -> errorExpectedDesugaredObject obj
   obj@ConstInt{} -> objectSize (desugar obj)
   obj@ConstIntRaw{} -> errorExpectedDesugaredObject obj
   obj@ConstFloat{} -> objectSize (desugar obj)

diff --git a/eo-phi-normalizer/src/Language/EO/Phi/Rules/Fast.hs b/eo-phi-normalizer/src/Language/EO/Phi/Rules/Fast.hs
@@ -213,6 +213,7 @@ fastYegorInsideOut ctx = \case
   MetaTailContext{} -> error "impossible MetaTailContext!"
   MetaFunction{} -> error "impossible MetaFunction!"
   obj@ConstString{} -> obj -- fastYegorInsideOut ctx (desugar obj)
+  obj@ConstStringRaw{} -> errorExpectedDesugaredObject obj -- fastYegorInsideOut ctx (desugar obj)
   obj@ConstInt{} -> obj -- fastYegorInsideOut ctx (desugar obj)
   obj@ConstIntRaw{} -> errorExpectedDesugaredObject obj -- fastYegorInsideOut ctx (desugar obj)
   obj@ConstFloat{} -> obj -- fastYegorInsideOut ctx (desugar obj)

diff --git a/eo-phi-normalizer/src/Language/EO/Phi/Rules/Yaml.hs b/eo-phi-normalizer/src/Language/EO/Phi/Rules/Yaml.hs
@@ -240,6 +240,7 @@ objectLabelIds = \case
   MetaSubstThis obj obj' -> objectLabelIds obj <> objectLabelIds obj'
   MetaContextualize obj obj' -> objectLabelIds obj <> objectLabelIds obj'
   obj@ConstString{} -> objectLabelIds (desugar obj)
+  obj@ConstStringRaw{} -> errorExpectedDesugaredObject obj
   obj@ConstInt{} -> objectLabelIds (desugar obj)
   obj@ConstIntRaw{} -> errorExpectedDesugaredObject obj
   obj@ConstFloat{} -> objectLabelIds (desugar obj)
@@ -291,6 +292,7 @@ objectMetaIds (MetaTailContext obj x) = objectMetaIds obj <> Set.singleton (Meta
 objectMetaIds (MetaSubstThis obj obj') = foldMap objectMetaIds [obj, obj']
 objectMetaIds (MetaContextualize obj obj') = foldMap objectMetaIds [obj, obj']
 objectMetaIds obj@ConstString{} = objectMetaIds (desugar obj)
+objectMetaIds obj@ConstStringRaw{} = errorExpectedDesugaredObject obj
 objectMetaIds obj@ConstInt{} = objectMetaIds (desugar obj)
 objectMetaIds obj@ConstIntRaw{} = errorExpectedDesugaredObject obj
 objectMetaIds obj@ConstFloat{} = objectMetaIds (desugar obj)
@@ -328,6 +330,7 @@ objectHasMetavars MetaTailContext{} = True
 objectHasMetavars (MetaSubstThis _ _) = True -- technically not a metavar, but a substitution
 objectHasMetavars (MetaContextualize _ _) = True
 objectHasMetavars obj@ConstString{} = objectHasMetavars (desugar obj)
+objectHasMetavars obj@ConstStringRaw{} = errorExpectedDesugaredObject obj
 objectHasMetavars obj@ConstInt{} = objectHasMetavars (desugar obj)
 objectHasMetavars obj@ConstIntRaw{} = errorExpectedDesugaredObject obj
 objectHasMetavars obj@ConstFloat{} = objectHasMetavars (desugar obj)
@@ -464,6 +467,7 @@ applySubst subst@Subst{..} = \case
         let holeSubst = mempty{objectMetas = [(holeMetaId, applySubst subst obj)]}
          in applySubst holeSubst contextObject
   obj@ConstString{} -> applySubst subst (desugar obj)
+  obj@ConstStringRaw{} -> errorExpectedDesugaredObject obj
   obj@ConstInt{} -> applySubst subst (desugar obj)
   obj@ConstIntRaw{} -> errorExpectedDesugaredObject obj
   obj@ConstFloat{} -> applySubst subst (desugar obj)
@@ -538,6 +542,7 @@ matchOneHoleContext ctxId pat obj = matchWhole <> matchPart
     ThisObject -> []
     Termination -> []
     ConstString{} -> []
+    ConstStringRaw{} -> errorExpectedDesugaredObject obj
     ConstInt{} -> []
     ConstIntRaw{} -> errorExpectedDesugaredObject obj
     ConstFloat{} -> []
@@ -658,6 +663,7 @@ substThis thisObj = go
     obj@MetaObject{} -> error ("impossible: trying to substitute ξ in " <> printTree obj)
     obj@MetaFunction{} -> error ("impossible: trying to substitute ξ in " <> printTree obj)
     obj@ConstString{} -> obj
+    obj@ConstStringRaw{} -> errorExpectedDesugaredObject obj
     obj@ConstInt{} -> obj
     obj@ConstIntRaw{} -> errorExpectedDesugaredObject obj
     obj@ConstFloat{} -> obj
@@ -698,6 +704,7 @@ contextualize thisObj = go
     obj@MetaObject{} -> error ("impossible: trying to contextualize " <> printTree obj)
     obj@MetaFunction{} -> error ("impossible: trying to contextualize " <> printTree obj)
     obj@ConstString{} -> go (desugar obj)
+    obj@ConstStringRaw{} -> errorExpectedDesugaredObject obj
     obj@ConstInt{} -> go (desugar obj)
     obj@ConstIntRaw{} -> errorExpectedDesugaredObject obj
     obj@ConstFloat{} -> go (desugar obj)

diff --git a/eo-phi-normalizer/src/Language/EO/Phi/Syntax.hs b/eo-phi-normalizer/src/Language/EO/Phi/Syntax.hs
@@ -122,6 +122,7 @@ instance DesugarableInitially Object where
   desugarInitially :: Object -> Object
   desugarInitially = \case
     obj@(ConstString{}) -> obj
+    ConstStringRaw (StringRaw s) -> ConstString (init (tail s))
     obj@(ConstInt{}) -> obj
     ConstIntRaw (IntegerSigned x) -> ConstInt (read x)
     obj@(ConstFloat{}) -> obj
@@ -181,6 +182,7 @@ instance SugarableFinally Object where
   sugarFinally = \case
     "Φ.org.eolang" -> GlobalObjectPhiOrg
     obj@ConstString{} -> obj
+    obj@ConstStringRaw{} -> errorExpectedDesugaredObject obj
     obj@ConstInt{} -> obj
     obj@ConstIntRaw{} -> errorExpectedDesugaredObject obj
     obj@ConstFloat{} -> obj
@@ -231,6 +233,7 @@ instance SugarableFinally MetaId
 desugar :: Object -> Object
 desugar = \case
   ConstString string -> wrapBytesInString (stringToBytes string)
+  obj@ConstStringRaw{} -> errorExpectedDesugaredObject obj
   ConstInt n -> wrapBytesInInt (intToBytes (fromInteger n))
   obj@ConstIntRaw{} -> errorExpectedDesugaredObject obj
   ConstFloat x -> wrapBytesInFloat (floatToBytes x)
@@ -675,3 +678,20 @@ printTree :: (Pretty a, SugarableFinally a) => a -> String
 printTree =
   printTreeDontSugar
     . sugarFinally
+
+-- >>> stringToBytes "Hello world"
+-- Bytes "48-65-6C-6C-6F-20-77-6F-72-6C-64"
+
+newtype A = A String
+instance Show A where show (A s) = s
+
+t1 = do
+  t <- readFile "tmp/bar.phi"
+  pure $ A (printTreeDontSugar (fromString t :: Program))
+
+-- >>> t1
+-- {
+--   ⟦
+--     org ↦ "\u0001"
+--   ⟧
+-- }
diff --git a/eo-phi-normalizer/src/Language/EO/Phi/Syntax/Abs.hs b/eo-phi-normalizer/src/Language/EO/Phi/Syntax/Abs.hs
diff --git a/eo-phi-normalizer/src/Language/EO/Phi/Syntax/Doc.txt b/eo-phi-normalizer/src/Language/EO/Phi/Syntax/Doc.txt
diff --git a/eo-phi-normalizer/src/Language/EO/Phi/Syntax/Lex.x b/eo-phi-normalizer/src/Language/EO/Phi/Syntax/Lex.x
diff --git a/eo-phi-normalizer/src/Language/EO/Phi/Syntax/Par.y b/eo-phi-normalizer/src/Language/EO/Phi/Syntax/Par.y
diff --git a/eo-phi-normalizer/src/Language/EO/Phi/ToLaTeX.hs b/eo-phi-normalizer/src/Language/EO/Phi/ToLaTeX.hs
@@ -91,6 +91,7 @@ instance ToLatex Object where
   toLatex (MetaSubstThis obj1 obj2) = LaTeX "\\mathbb{S}(" <> toLatex obj1 <> ", " <> toLatex obj2 <> ")"
   toLatex (MetaContextualize obj1 obj2) = LaTeX "\\lceil" <> toLatex obj1 <> ", " <> toLatex obj2 <> "\\rceil"
   toLatex (ConstString string) = "|" <> LaTeX (show string) <> "|"
+  toLatex obj@(ConstStringRaw{}) = errorExpectedDesugaredObject obj
   toLatex (ConstInt n) = LaTeX (show n)
   toLatex obj@(ConstIntRaw{}) = errorExpectedDesugaredObject obj
   toLatex (ConstFloat x) = LaTeX (show x)

diff --git a/eo-phi-normalizer/test/Language/EO/Rules/PhiPaperSpec.hs b/eo-phi-normalizer/test/Language/EO/Rules/PhiPaperSpec.hs
@@ -112,6 +112,9 @@ instance Arbitrary Binding where
   shrink (AlphaBinding attr obj) = AlphaBinding attr <$> shrink obj
   shrink _ = [] -- do not shrink deltas and lambdas
 
+instance Arbitrary Phi.StringRaw where
+  arbitrary = Phi.StringRaw <$> arbitraryNonEmptyString
+
 -- | Split an integer into a list of positive integers,
 -- whose sum is less than or equal the initial one.
 --