build: ghcid: run even with warnings

[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..44c6b785f37a4b53d52936b6fdfc5ef18b0c48e7 100644 (file)
--- a/src/Symantic/Parser/Grammar/Write.hs
+++ b/src/Symantic/Parser/Grammar/Write.hs
@@ -2,25 +2,29 @@
 module Symantic.Parser.Grammar.Write where
 
 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 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.Semantics.SharingObserver
+import Symantic.Semantics.Viewer.Fixity
 import Symantic.Parser.Grammar.Combinators
 
 -- * 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 +44,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,22 +58,33 @@ 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
-  pure _ = WriteGrammar $ return Nothing
+instance CombApplicable (WriteGrammar sN) where
+  pure _ = WriteGrammar $ return Nothing{-TODO: print?-}
   -- pure _ = "pure"
   WriteGrammar x <*> WriteGrammar y = WriteGrammar $ \inh ->
     let inh' side = inh
@@ -84,50 +101,47 @@ 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
-    where
-    op = infixN 9
-  x <|> y = WriteGrammar $ \inh ->
+      Just "chainPre " <>
+      unWriteGrammar f inh <> Just " " <>
+      unWriteGrammar x inh
+    where op = infixN 9
+  chainPost f x = 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 ->
+      Just "chainPost " <>
+      unWriteGrammar f inh <> Just " " <>
+      unWriteGrammar x inh
+    where op = infixN 9
+instance
+  ( Show letName
+  , HideName letName
+  , HideableName sN
+  ) => Referenceable letName (WriteGrammar sN) where
+  ref isRec name = WriteGrammar $ \inh ->
     pairWriteGrammarInh inh op $
-      Just "branch " <>
-      unWriteGrammar lr inh <> Just " " <>
-      unWriteGrammar l inh <> Just " " <>
-      unWriteGrammar r inh
+      Just (if isRec then "rec " else "ref ") <>
+      Just (fromString (show (hideableName @sN name)))
     where
     op = infixN 9
-instance Matchable WriteGrammar where
-  conditional _cs bs a b = WriteGrammar $ \inh ->
+instance
+  ( Show letName
+  , HideName letName
+  , HideableName sN
+  ) => 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 (show (hideableName @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 +150,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 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 <>
+      unWriteGrammar d inh <>
+      Just " [" <>
+      Just (mconcat (List.intersperse ", " $
+      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
+  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