test: update

[haskell/symantic-parser.git] / src / Symantic / Parser / Grammar / Write.hs

diff --git a/src/Symantic/Parser/Grammar/Write.hs b/src/Symantic/Parser/Grammar/Write.hs
index 24f8de33feb96253a249f7d0b384e7e7a1134b3c..36da73857fea21c7e3907547436adf7c34c1f9e8 100644 (file)
--- a/src/Symantic/Parser/Grammar/Write.hs
+++ b/src/Symantic/Parser/Grammar/Write.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Symantic.Parser.Grammar.Write where
 
+import Data.Bool (Bool(..))
 import Control.Monad (Monad(..))
 import Data.Function (($))
 import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
@@ -8,19 +9,21 @@ import Data.Monoid (Monoid(..))
 import Data.Semigroup (Semigroup(..))
 import Data.String (IsString(..))
 import Text.Show (Show(..))
-import qualified Data.Functor as Pre
+import qualified Data.Functor as Functor
+import qualified Data.HashMap.Strict as HM
 import qualified Data.List as List
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Builder as TLB
 
-import Symantic.Base.Fixity
 import Symantic.Univariant.Letable
 import Symantic.Parser.Grammar.Combinators
+import Symantic.Parser.Grammar.Fixity
 
 -- * Type 'WriteGrammar'
-newtype WriteGrammar a = WriteGrammar { unWriteGrammar :: WriteGrammarInh -> Maybe TLB.Builder }
+newtype WriteGrammar (showName::Bool) a = WriteGrammar { unWriteGrammar ::
+  WriteGrammarInh -> Maybe TLB.Builder }
 
-instance IsString (WriteGrammar a) where
+instance IsString (WriteGrammar sN a) where
   fromString s = WriteGrammar $ \_inh ->
     if List.null s then Nothing
     else Just (fromString s)
@@ -40,8 +43,10 @@ emptyWriteGrammarInh = WriteGrammarInh
  , writeGrammarInh_pair = pairParen
  }
 
-writeGrammar :: WriteGrammar a -> TL.Text
-writeGrammar (WriteGrammar r) = TLB.toLazyText $ fromMaybe "" $ r emptyWriteGrammarInh
+writeGrammar :: WriteGrammar sN a -> TL.Text
+writeGrammar (WriteGrammar go) =
+  TLB.toLazyText $ fromMaybe "" $
+  go emptyWriteGrammarInh
 
 pairWriteGrammarInh ::
  Semigroup s => IsString s =>
@@ -52,21 +57,32 @@ pairWriteGrammarInh inh op s =
   else s
   where (o,c) = writeGrammarInh_pair inh
 
-instance Show letName => Letable letName WriteGrammar where
-  def name x = WriteGrammar $ \inh ->
+instance CombAlternable (WriteGrammar sN) where
+  alt exn x y = WriteGrammar $ \inh ->
     pairWriteGrammarInh inh op $
-      Just "def "
-      <> Just (fromString (show name))
-      <> unWriteGrammar x inh
+    unWriteGrammar x inh
+     { writeGrammarInh_op = (op, SideL)
+     , writeGrammarInh_pair = pairParen
+     } <>
+    Just (" |^"<>fromString (show exn)<>" ") <>
+    unWriteGrammar y inh
+     { writeGrammarInh_op = (op, SideR)
+     , writeGrammarInh_pair = pairParen
+     }
+    where op = infixB SideL 3
+  throw exn = WriteGrammar $ \inh ->
+    pairWriteGrammarInh inh op $
+      Just ("throw "<>fromString (show exn))
     where
     op = infixN 9
-  ref rec name = WriteGrammar $ \inh ->
+  failure _sf = "failure"
+  empty = "empty"
+  try x = WriteGrammar $ \inh ->
     pairWriteGrammarInh inh op $
-      Just (if rec then "rec " else "ref ") <>
-      Just (fromString (show name))
+      Just "try " <> unWriteGrammar x inh
     where
     op = infixN 9
-instance Applicable WriteGrammar where
+instance CombApplicable (WriteGrammar sN) where
   pure _ = WriteGrammar $ return Nothing
   -- pure _ = "pure"
   WriteGrammar x <*> WriteGrammar y = WriteGrammar $ \inh ->
@@ -84,50 +100,50 @@ instance Applicable WriteGrammar where
           Just $ xt <> ", " <> yt
     where
     op = infixN 1
-instance Alternable WriteGrammar where
-  empty = "empty"
-  try x = WriteGrammar $ \inh ->
+instance CombFoldable (WriteGrammar sN) where
+  chainPre f x = WriteGrammar $ \inh ->
     pairWriteGrammarInh inh op $
-      Just "try " <> unWriteGrammar x inh
+      Just "chainPre " <>
+      unWriteGrammar f inh <> Just " " <>
+      unWriteGrammar x inh
+    where op = infixN 9
+  chainPost f x = WriteGrammar $ \inh ->
+    pairWriteGrammarInh inh op $
+      Just "chainPost " <>
+      unWriteGrammar f inh <> Just " " <>
+      unWriteGrammar x inh
+    where op = infixN 9
+instance
+  ShowLetName sN letName =>
+  Letable letName (WriteGrammar sN) where
+  shareable name x = WriteGrammar $ \inh ->
+    pairWriteGrammarInh inh op $
+      Just "shareable "
+      <> Just (fromString (showLetName @sN name))
+      <> unWriteGrammar x inh
     where
     op = infixN 9
-  x <|> y = WriteGrammar $ \inh ->
-    pairWriteGrammarInh inh op $
-    unWriteGrammar x inh
-     { writeGrammarInh_op = (op, SideL)
-     , writeGrammarInh_pair = pairParen
-     } <>
-    Just " | " <>
-    unWriteGrammar y inh
-     { writeGrammarInh_op = (op, SideR)
-     , writeGrammarInh_pair = pairParen
-     }
-    where op = infixB SideL 3
-instance Charable WriteGrammar where
-  satisfy _f = "sat"
-instance Selectable WriteGrammar where
-  branch lr l r = WriteGrammar $ \inh ->
+  ref rec name = WriteGrammar $ \inh ->
     pairWriteGrammarInh inh op $
-      Just "branch " <>
-      unWriteGrammar lr inh <> Just " " <>
-      unWriteGrammar l inh <> Just " " <>
-      unWriteGrammar r inh
+      Just (if rec then "rec " else "ref ") <>
+      Just (fromString (showLetName @sN name))
     where
     op = infixN 9
-instance Matchable WriteGrammar where
-  conditional _cs bs a b = WriteGrammar $ \inh ->
+instance
+  ShowLetName sN letName =>
+  Letsable letName (WriteGrammar sN) where
+  lets defs x = WriteGrammar $ \inh ->
     pairWriteGrammarInh inh op $
-      Just "conditional " <>
-      Just "[" <>
-      Just (mconcat (List.intersperse ", " $
-      catMaybes $ (Pre.<$> bs) $ \x ->
-        unWriteGrammar x inh{writeGrammarInh_op=(infixN 0, SideL)})) <>
-      Just "] " <>
-      unWriteGrammar a inh <> Just " " <>
-      unWriteGrammar b inh
+      Just "let "
+      <> HM.foldMapWithKey
+        (\name (SomeLet val) ->
+          Just (fromString (showLetName @sN name))
+          <> unWriteGrammar val inh)
+        defs
+      <> unWriteGrammar x inh
     where
     op = infixN 9
-instance Lookable WriteGrammar where
+instance CombLookable (WriteGrammar sN) where
   look x = WriteGrammar $ \inh ->
     pairWriteGrammarInh inh op $
       Just "look " <> unWriteGrammar x inh
@@ -136,16 +152,28 @@ instance Lookable WriteGrammar where
     pairWriteGrammarInh inh op $
       Just "negLook " <> unWriteGrammar x inh
     where op = infixN 9
-instance Foldable WriteGrammar where
-  chainPre f x = WriteGrammar $ \inh ->
+  eof = "eof"
+instance CombMatchable (WriteGrammar sN) where
+  conditional a _ps bs d = WriteGrammar $ \inh ->
     pairWriteGrammarInh inh op $
-      Just "chainPre " <>
-      unWriteGrammar f inh <> Just " " <>
-      unWriteGrammar x inh
-    where op = infixN 9
-  chainPost f x = WriteGrammar $ \inh ->
+      Just "conditional " <>
+      unWriteGrammar a inh <>
+      Just " [" <>
+      Just (mconcat (List.intersperse ", " $
+      catMaybes $ (Functor.<$> bs) $ \x ->
+        unWriteGrammar x inh{writeGrammarInh_op=(infixN 0, SideL)})) <>
+      Just "] " <>
+      unWriteGrammar d inh
+    where
+    op = infixN 9
+instance CombSatisfiable tok (WriteGrammar sN) where
+  satisfyOrFail _fs _f = "satisfy"
+instance CombSelectable (WriteGrammar sN) where
+  branch lr l r = WriteGrammar $ \inh ->
     pairWriteGrammarInh inh op $
-      Just "chainPost " <>
-      unWriteGrammar f inh <> Just " " <>
-      unWriteGrammar x inh
-    where op = infixN 9
+      Just "branch " <>
+      unWriteGrammar lr inh <> Just " " <>
+      unWriteGrammar l inh <> Just " " <>
+      unWriteGrammar r inh
+    where
+    op = infixN 9