copyright: comply with REUSE-3.0

[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 36da73857fea21c7e3907547436adf7c34c1f9e8..7040940409e444f505237c7f5c0f48152394f57d 100644 (file)
--- a/src/Symantic/Parser/Grammar/Write.hs
+++ b/src/Symantic/Parser/Grammar/Write.hs
@@ -1,13 +1,14 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Symantic.Parser.Grammar.Write where
 
-import Data.Bool (Bool(..))
 import Control.Monad (Monad(..))
+import Data.Bool (Bool(..))
 import Data.Function (($))
 import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
 import Data.Monoid (Monoid(..))
 import Data.Semigroup (Semigroup(..))
 import Data.String (IsString(..))
+import Language.Haskell.TH.HideName
 import Text.Show (Show(..))
 import qualified Data.Functor as Functor
 import qualified Data.HashMap.Strict as HM
@@ -15,9 +16,9 @@ import qualified Data.List as List
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Builder as TLB
 
-import Symantic.Univariant.Letable
+import Symantic.ObserveSharing
+import Symantic.Fixity
 import Symantic.Parser.Grammar.Combinators
-import Symantic.Parser.Grammar.Fixity
 
 -- * Type 'WriteGrammar'
 newtype WriteGrammar (showName::Bool) a = WriteGrammar { unWriteGrammar ::
@@ -83,7 +84,7 @@ instance CombAlternable (WriteGrammar sN) where
     where
     op = infixN 9
 instance CombApplicable (WriteGrammar sN) where
-  pure _ = WriteGrammar $ return Nothing
+  pure _ = WriteGrammar $ return Nothing{-TODO: print?-}
   -- pure _ = "pure"
   WriteGrammar x <*> WriteGrammar y = WriteGrammar $ \inh ->
     let inh' side = inh
@@ -114,30 +115,27 @@ instance CombFoldable (WriteGrammar sN) where
       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
-  ref rec name = WriteGrammar $ \inh ->
+  ( Show letName
+  , HideName letName
+  , HideableName sN
+  ) => Referenceable letName (WriteGrammar sN) where
+  ref isRec name = WriteGrammar $ \inh ->
     pairWriteGrammarInh inh op $
-      Just (if rec then "rec " else "ref ") <>
-      Just (fromString (showLetName @sN name))
+      Just (if isRec then "rec " else "ref ") <>
+      Just (fromString (show (hideableName @sN name)))
     where
     op = infixN 9
 instance
-  ShowLetName sN letName =>
-  Letsable letName (WriteGrammar sN) where
+  ( Show letName
+  , HideName letName
+  , HideableName sN
+  ) => Letsable letName (WriteGrammar sN) where
   lets defs x = WriteGrammar $ \inh ->
     pairWriteGrammarInh inh op $
       Just "let "
       <> HM.foldMapWithKey
         (\name (SomeLet val) ->
-          Just (fromString (showLetName @sN name))
+          Just (fromString (show (hideableName @sN name)))
           <> unWriteGrammar val inh)
         defs
       <> unWriteGrammar x inh
@@ -154,16 +152,16 @@ instance CombLookable (WriteGrammar sN) where
     where op = infixN 9
   eof = "eof"
 instance CombMatchable (WriteGrammar sN) where
-  conditional a _ps bs d = WriteGrammar $ \inh ->
+  conditional a bs d = WriteGrammar $ \inh ->
     pairWriteGrammarInh inh op $
       Just "conditional " <>
       unWriteGrammar a inh <>
+      unWriteGrammar d inh <>
       Just " [" <>
       Just (mconcat (List.intersperse ", " $
-      catMaybes $ (Functor.<$> bs) $ \x ->
-        unWriteGrammar x inh{writeGrammarInh_op=(infixN 0, SideL)})) <>
-      Just "] " <>
-      unWriteGrammar d inh
+      catMaybes $ (Functor.<$> bs) $ \(p{-TODO: print?-}, b) ->
+        unWriteGrammar b inh{writeGrammarInh_op=(infixN 0, SideL)})) <>
+      Just "] "
     where
     op = infixN 9
 instance CombSatisfiable tok (WriteGrammar sN) where