test: add goldens for TH splices

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

diff --git a/src/Symantic/Parser/Grammar/ObserveSharing.hs b/src/Symantic/Parser/Grammar/ObserveSharing.hs
index a23d670dc0592f41a403333caa95a1b3e73267e4..d17ce334d4dc798da25a56590216b2659793ea46 100644 (file)
--- a/src/Symantic/Parser/Grammar/ObserveSharing.hs
+++ b/src/Symantic/Parser/Grammar/ObserveSharing.hs
@@ -1,107 +1,111 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Symantic.Parser.Grammar.ObserveSharing
- ( module Symantic.Parser.Grammar.ObserveSharing
- , ObserveSharing(..)
- ) where
+  ( module Symantic.Univariant.Letable
+  , module Symantic.Parser.Grammar.ObserveSharing
+  ) where
 
 import Control.Monad (mapM)
-import Control.Applicative (Applicative(..))
 import Data.Eq (Eq(..))
 import Data.Function (($), (.))
-import Data.Functor ((<$>))
 import Data.Hashable (Hashable, hashWithSalt)
 import Text.Show (Show(..))
+import qualified Control.Applicative as Functor
 
-import Symantic.Univariant.Letable as Letable
-import qualified Symantic.Univariant.Trans as Sym
-import qualified Symantic.Parser.Grammar.Combinators as Comb
+import Symantic.Parser.Grammar.Combinators
+import Symantic.Univariant.Letable hiding (observeSharing)
+import qualified Symantic.Univariant.Letable as Letable
 import qualified Language.Haskell.TH.Syntax as TH
+import qualified Symantic.Univariant.Trans as Sym
 
 -- | Like 'Letable.observeSharing'
--- but type-binding @(letName)@ to 'TH.Name' to help type inference.
+-- but type-binding @(letName)@ to 'TH.Name'
+-- to avoid the trouble to always set it.
 observeSharing :: ObserveSharing TH.Name repr a -> repr a
 observeSharing = Letable.observeSharing
 
+-- | Needed by 'observeSharing'.
 instance Hashable TH.Name where
   hashWithSalt s = hashWithSalt s . show
 
--- Combinators semantics for the 'ObserveSharing' interpreter
+-- Combinators semantics for the 'ObserveSharing' interpreter.
 instance
   ( Letable letName repr
   , MakeLetName letName
   , Eq letName
   , Hashable letName
-  , Comb.Satisfiable repr tok
-  ) => Comb.Satisfiable (ObserveSharing letName repr) tok
+  , Satisfiable tok repr
+  ) => Satisfiable tok (ObserveSharing letName repr)
 instance
   ( Letable letName repr
   , MakeLetName letName
   , Eq letName
   , Hashable letName
-  , Comb.Alternable repr
-  ) => Comb.Alternable (ObserveSharing letName repr)
+  , Alternable repr
+  ) => Alternable (ObserveSharing letName repr)
 instance
   ( Letable letName repr
   , MakeLetName letName
   , Eq letName
   , Hashable letName
-  , Comb.Applicable repr
-  ) => Comb.Applicable (ObserveSharing letName repr)
+  , Applicable repr
+  ) => Applicable (ObserveSharing letName repr)
 instance
   ( Letable letName repr
   , MakeLetName letName
   , Eq letName
   , Hashable letName
-  , Comb.Selectable repr
-  ) => Comb.Selectable (ObserveSharing letName repr)
+  , Selectable repr
+  ) => Selectable (ObserveSharing letName repr)
 instance
   ( Letable letName repr
   , MakeLetName letName
   , Eq letName
   , Hashable letName
-  , Comb.Matchable repr
-  ) => Comb.Matchable (ObserveSharing letName repr) where
+  , Matchable repr
+  ) => Matchable (ObserveSharing letName repr) where
   -- Here the default definition does not fit
   -- since there is no lift* for the type of 'conditional'
-  -- and its default definition handles does not handles 'bs'
+  -- and its default definition does not handles 'bs'
   -- as needed by the 'ObserveSharing' transformation.
-  conditional cs bs a b = observeSharingNode $ ObserveSharing $
-    Comb.conditional cs
-      <$> mapM unObserveSharing bs
-      <*> unObserveSharing a
-      <*> unObserveSharing b
+  conditional a cs bs b = observeSharingNode $ ObserveSharing $
+    conditional
+      Functor.<$> unObserveSharing a
+      Functor.<*> Functor.pure cs
+      Functor.<*> mapM unObserveSharing bs
+      Functor.<*> unObserveSharing b
 instance
   ( Letable letName repr
   , MakeLetName letName
   , Eq letName
   , Hashable letName
-  , Comb.Foldable repr
+  , Foldable repr
   {- TODO: the following constraints are for the current Foldable,
    - they will have to be removed when Foldable will have Sym.lift2 as defaults
    -}
-  , Comb.Applicable repr
-  , Comb.Alternable repr
-  ) => Comb.Foldable (ObserveSharing letName repr)
+  , Applicable repr
+  , Alternable repr
+  ) => Foldable (ObserveSharing letName repr)
 instance
   ( Letable letName repr
   , MakeLetName letName
   , Eq letName
   , Hashable letName
-  , Comb.Lookable repr
-  ) => Comb.Lookable (ObserveSharing letName repr)
+  , Lookable repr
+  ) => Lookable (ObserveSharing letName repr)
 
--- Combinators semantics for the 'CleanDefs' interpreter
-instance Comb.Applicable repr => Comb.Applicable (CleanDefs letName repr)
-instance Comb.Alternable repr => Comb.Alternable (CleanDefs letName repr)
-instance Comb.Satisfiable repr tok => Comb.Satisfiable (CleanDefs letName repr) tok
-instance Comb.Selectable repr => Comb.Selectable (CleanDefs letName repr)
-instance Comb.Matchable repr => Comb.Matchable (CleanDefs letName repr) where
-  conditional cs bs a b = CleanDefs $
-    Comb.conditional cs
-      <$> mapM unCleanDefs bs
-      <*> unCleanDefs a
-      <*> unCleanDefs b
-instance Comb.Lookable repr => Comb.Lookable (CleanDefs letName repr)
-instance Comb.Foldable repr => Comb.Foldable (CleanDefs letName repr) where
-  chainPre = Sym.lift2 Comb.chainPre
-  chainPost = Sym.lift2 Comb.chainPost
+-- Combinators semantics for the 'CleanDefs' interpreter.
+instance Applicable repr => Applicable (CleanDefs letName repr)
+instance Alternable repr => Alternable (CleanDefs letName repr)
+instance Satisfiable tok repr => Satisfiable tok (CleanDefs letName repr)
+instance Selectable repr => Selectable (CleanDefs letName repr)
+instance Matchable repr => Matchable (CleanDefs letName repr) where
+  conditional a cs bs b = CleanDefs $
+    conditional
+      Functor.<$> unCleanDefs a
+      Functor.<*> Functor.pure cs
+      Functor.<*> mapM unCleanDefs bs
+      Functor.<*> unCleanDefs b
+instance Lookable repr => Lookable (CleanDefs letName repr)
+instance Foldable repr => Foldable (CleanDefs letName repr) where
+  chainPre = Sym.lift2 chainPre
+  chainPost = Sym.lift2 chainPost