qq

src/Gyehoek/Sexp/Syntax.hs

@@ -19,6 +19,8 @@ module Gyehoek.Sexp.Syntax
   , pattern Compound
   , pattern Labeled
   , pattern LabelRef
+  , pattern Meta
+  , pattern MetaSplice
   , pattern Abbrev
   , pattern Vector
   , pattern DotList
@@ -38,19 +40,26 @@ module Gyehoek.Sexp.Syntax
   , ann
   , pattern List'
   , position
+  , stripAnn
   ) where
 
-import Language.Haskell.TH.Syntax (Lift)
+import Language.Haskell.TH.Syntax (Lift (lift), liftData)
 import Data.Scientific (Scientific)
 import Data.ByteString (ByteString)
 import Gyehoek.Prelude hiding ((:<), Simple)
 import Text.Megaparsec.Pos (SourcePos(..), sourcePosPretty)
-import Control.Comonad.Cofree (Cofree((:<)), _extract)
+import Control.Comonad.Cofree (Cofree((:<)), _extract, _unwrap)
 import Data.Fix (Fix (..))
 import Data.Functor.Foldable
 import Text.Show.Deriving (deriveShow1)
+import Data.Eq.Deriving (deriveEq1)
 import qualified Control.Comonad.Trans.Cofree as F
 import Prettyprinter (Pretty (pretty), viaShow)
+import Gyehoek.Lift1 (Lift1 (liftLift))
+import Data.Data (Typeable, cast)
+import Language.Haskell.TH
+import qualified Data.Text as T
+import Control.Comonad.Trans.Cofree (tailF)
 
 
 data DatumF a
@@ -58,6 +67,8 @@ data DatumF a
   | CompoundF (CompoundF a)
   | LabeledF Label a
   | LabelRefF Label
+  | MetaF Text
+  | MetaSpliceF Text
   deriving stock (Show, Eq, Data, Generic, Lift, Functor, Foldable, Traversable)
   deriving anyclass (NFData)
 
@@ -68,8 +79,6 @@ data Simple
   | SimpleString Text
   | SimpleSymbol Text
   | SimpleBytevector ByteString
-  | SimpleMeta Text
-  | SimpleMetaSplice Text
   deriving stock (Show, Eq, Data, Generic, Lift)
   deriving anyclass (NFData)
 
@@ -135,10 +144,13 @@ noAnn = MkAnn
 instance Pretty Ann where
   pretty = pretty . maybe "<unknown>" sourcePosPretty . view #position
 
-
-
 deriveShow1 ''CompoundF
+deriveEq1 ''CompoundF
 deriveShow1 ''DatumF
+deriveEq1 ''DatumF
+
+
+--- modification and extraction of annotations
 
 ann :: Lens' Datum Ann
 ann = _extract
@@ -161,6 +173,12 @@ adorn = set syntax
 indentWith :: Indentation -> Datum -> Datum
 indentWith = set indentation
 
+stripAnn :: Datum -> Fix DatumF
+stripAnn = hoist tailF
+
+
+--- pattern synonyms
+
 pattern Simple :: Simple -> Datum
 pattern Simple a <- _ :< SimpleF a
   where Simple a = noAnn :< SimpleF a
@@ -177,6 +195,14 @@ pattern LabelRef :: Label -> Datum
 pattern LabelRef l <- _ :< LabelRefF l
   where LabelRef l = noAnn :< LabelRefF l
 
+pattern MetaSplice :: Text -> Datum
+pattern MetaSplice x <- _ :< MetaSpliceF x
+  where MetaSplice x = noAnn :< MetaSpliceF x
+
+pattern Meta :: Text -> Datum
+pattern Meta x <- _ :< MetaF x
+  where Meta x = noAnn :< MetaF x
+
 pattern List :: List Datum -> Datum
 pattern List a <- _ :< CompoundF (ListF _ a)
   where List a = noAnn :< CompoundF (ListF Ordinary a)
@@ -203,3 +229,22 @@ pattern Character a = Simple (SimpleCharacter a)
 pattern String a = Simple (SimpleString a)
 pattern Symbol a = Simple (SimpleSymbol a)
 pattern Bytevector a = Simple (SimpleBytevector a)
+
+
+--- Lift1 instances
+
+instance Lift1 DatumF where
+  liftLift l = \case
+    SimpleF s -> [|SimpleF $(lift s)|]
+    CompoundF c -> [|CompoundF $(liftLift l c)|]
+    LabeledF lbl x -> [|LabeledF $(lift lbl) $(l x)|]
+    LabelRefF lbl -> [|LabelRefF $(lift lbl)|]
+    MetaF x -> [|MetaF $(lift x)|]
+    MetaSpliceF x -> [|MetaSpliceF $(lift x)|]
+
+instance Lift1 CompoundF where
+  liftLift l = \case
+    ListF ind xs -> [|ListF $(lift ind) $(liftLift l xs)|]
+    DotListF xs t -> [|DotListF $(liftLift l xs) $(l t)|]
+    VectorF xs -> [|VectorF $(liftLift l xs)|]
+    AbbrevF p x -> [|AbbrevF $(lift p) $(l x)|]