qq!

src/Gyehoek/Sexp.hs

@@ -34,11 +34,16 @@ module Gyehoek.Sexp
   , sxs
   , makeSx
   , makeSxs
+  , toSexp
+  , fromSexp
+  , stripLocation
+  , sx'
+  , sxs'
   )
 where
 
 import Data.Text (Text)
-import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty)
+import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty, fromSexp)
 import Language.SexpGrammar qualified as Sexp
 import Language.Sexp qualified as S
 import Language.SexpGrammar.Generic
@@ -67,6 +72,9 @@ import qualified Data.Text as T
 import qualified Control.Category
 import Data.Data (Data, Typeable, cast)
 import Language.Haskell.TH.Syntax (lift, Lift)
+import GHC.IsList (fromList)
+import Data.Functor.Foldable (cata)
+import Data.Functor.Classes (Show1(..))
 
 
 sexp :: SexpIso a => Iso' a Text
@@ -95,21 +103,21 @@ encodePrettyWith g =
 
 parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
 parseSexps f = marshal . SL.parseSexps f . view lazy . encodeUtf8
-  where marshal = join . traverseOf (_Right . each) (fromSexp sexpIso)
+  where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp sexpIso)
 
 parseSexp :: SexpIso a => FilePath -> Text -> Either String a
 parseSexp f = marshal . SL.parseSexp f . view lazy . encodeUtf8
-  where marshal = join . traverseOf _Right (fromSexp sexpIso)
+  where marshal = join . traverseOf _Right (Sexp.fromSexp sexpIso)
 
 parseSexpsWithPos :: SexpGrammar a -> Position -> Text -> Either String (List a)
 parseSexpsWithPos g pos =
   marshal . SL.parseSexpsWithPos pos . view lazy . encodeUtf8
-  where marshal = join . traverseOf (_Right . each) (fromSexp g)
+  where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp g)
 
 parseSexpWithPos :: SexpGrammar a -> Position -> Text -> Either String a
 parseSexpWithPos g pos =
   marshal . SL.parseSexpWithPos pos . view lazy . encodeUtf8
-  where marshal = join . traverseOf _Right (fromSexp g)
+  where marshal = join . traverseOf _Right (Sexp.fromSexp g)
 
 nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
 nonEmptyGrammar = IGB.Iso
@@ -231,21 +239,15 @@ getPos = do
   Loc {loc_filename,loc_start} <- location
   pure $ SL.Position loc_filename (fst loc_start) (snd loc_start)
 
-makeSxs :: Data b => SexpGrammar a -> (List a -> b) -> QuasiQuoter
-makeSxs g f = QuasiQuoter
-  { quoteExp = \str -> do
-      pos <- getPos
-      case parseSexpsWithPos g pos (T.pack str) of
-        Left e -> fail e
-        Right xs -> dataToExpQ (const Nothing) (f xs)
-  , quotePat = undefined
-  , quoteType = undefined
-  , quoteDec = undefined
-  }
+fromSexp :: SexpIso a => Sexp -> a
+fromSexp = either error id . Sexp.fromSexp sexpIso
 
 toSexp :: SexpIso a => a -> Sexp
 toSexp = either error id . Sexp.toSexp sexpIso
 
+toSexps :: (Foldable f, SexpIso a) => f a -> List Sexp
+toSexps = foldMap \x -> [toSexp x]
+
 pattern Unquote x =
   SL.Modified Hash (SL.BraceList [SL.Symbol x])
 pattern UnquoteSplicing x =
@@ -262,12 +264,17 @@ instance Each Sexp Sexp Sexp Sexp where
   each k (SL.BraceList xs)              = SL.BraceList <$> traverse k xs
   each _ e@(SL.Atom _; SL.Modified _ _) = pure e
 
+stripLocation :: Sexp -> Sexp
+stripLocation = cata \case
+  SL.Compose (a SL.:< e) ->
+    SL.Fix . SL.Compose $ SL.dummyPos SL.:< e
+
 metaSexp :: Sexp.Sexp -> Maybe ExpQ
 metaSexp (Unquote x) =
-  Just [| toSexp $(varE (mkName (T.unpack x))) |]
+  Just [| stripLocation . toSexp $ $(varE (mkName (T.unpack x))) |]
 metaSexp (SL.ParenList xs)
   | (_:_) <- xs ^.. each . _UnquoteSplicing
-  = Just [| SL.ParenList (mconcat $(listE spans)) |]
+  = Just [| stripLocation . toSexp $ SL.ParenList (mconcat $(listE spans)) |]
   where
     spans = xs
       & groupBy \cases
@@ -275,8 +282,9 @@ metaSexp (SL.ParenList xs)
           _ (UnquoteSplicing _) -> False
           _ _                   -> True
       & fmap \case
-        [UnquoteSplicing x] -> varE (mkName (T.unpack x))
-        x -> lift x
+        [UnquoteSplicing x] ->
+          [| stripLocation <$> toSexps $(varE (mkName (T.unpack x))) |]
+        x -> [| stripLocation <$> x |]
 metaSexp _ = Nothing
 
 -- 뻘짓뻘짓뻘짓뻘짓뻘짓
@@ -287,10 +295,10 @@ lift1 :: (Lift1 f, Lift a, Quote m) => f a -> m Exp
 lift1 = liftLift lift
 
 instance Lift1 f => Lift (SL.Fix f) where
-  lift (SL.Fix inner) = appE [|Fix|] (lift1 inner)
+  lift (SL.Fix inner) = appE [|SL.Fix|] (lift1 inner)
 
 instance (Lift1 f, Lift1 g) => Lift1 (SL.Compose f g) where
-  liftLift l (SL.Compose fga) = [|Compose $(liftLift (liftLift l) fga)|]
+  liftLift l (SL.Compose fga) = [|SL.Compose $(liftLift (liftLift l) fga)|]
 
 instance Lift a => Lift1 (SL.LocatedBy a) where
   liftLift l (a SL.:< e) = [|(SL.:<) $(lift a) $(l e)|]
@@ -314,17 +322,36 @@ deriving instance Lift SL.Prefix
 extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r
 extQ f g a = maybe (f a) g (cast a)
 
-makeSx :: Data a => SexpGrammar a -> QuasiQuoter
-makeSx g = QuasiQuoter
+makeSxs
+  :: Data b
+  => (List a -> b) -> SexpGrammar a -> QuasiQuoter
+makeSxs f g = QuasiQuoter
   { quoteExp = \str -> do
       pos <- getPos
-      case parseSexpWithPos g pos (T.pack str) of
+      case parseSexpsWithPos g pos (T.pack str) of
         Left e -> fail e
-        Right x -> dataToExpQ (const Nothing `extQ` metaSexp) x
+        Right xs -> dataToExpQ (const Nothing `extQ` metaSexp) (f xs)
   , quotePat = undefined
   , quoteType = undefined
   , quoteDec = undefined
   }
 
-sxs = makeSxs (sexpIso @Sexp) id
-sx = makeSx (sexpIso @Sexp)
+makeSx
+  :: (Data a, Data r)
+  => (a -> r) -> SexpGrammar a -> QuasiQuoter
+makeSx f g = QuasiQuoter
+  { quoteExp = \str -> do
+      pos <- getPos
+      case parseSexpWithPos g pos (T.pack str) of
+        Left e -> fail e
+        Right x -> dataToExpQ (const Nothing `extQ` metaSexp) (f x)
+  , quotePat = undefined
+  , quoteType = undefined
+  , quoteDec = undefined
+  }
+
+sxs = makeSxs id (sexpIso @Sexp)
+sx = makeSx id (sexpIso @Sexp)
+
+sxs' = makeSxs (fmap stripLocation) (sexpIso @Sexp)
+sx' = makeSx stripLocation (sexpIso @Sexp)