qq

gyehoek.cabal

@@ -62,6 +62,7 @@ library
     Gyehoek.GenSym
     Gyehoek.Jalmot
     Gyehoek.Language
+    Gyehoek.Lift1
     Gyehoek.Options
     Gyehoek.Prelude
     Gyehoek.Scheme.Syntax
@@ -69,6 +70,7 @@ library
     Gyehoek.Sexp.Grammar
     Gyehoek.Sexp.Grammar.Base
     Gyehoek.Sexp.Print
+    Gyehoek.Sexp.QQ
     Gyehoek.Sexp.Read
     Gyehoek.Sexp.Syntax
     Gyehoek.Stack.Syntax
@@ -131,6 +133,7 @@ test-suite test
     Gyehoek.Test.Scheme.Syntax
     Gyehoek.Test.Sexp
     Gyehoek.Test.Sexp.Print
+    Gyehoek.Test.Sexp.QQ
     Gyehoek.Test.Sexp.Read
     Gyehoek.Test.Stack.VM
     Gyehoek.TestUtil

src/Gyehoek/Lift1.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Gyehoek.Lift1
+  ( Lift1(..)
+  , lift1
+  ) where
+
+import Gyehoek.Prelude hiding ((:<))
+import Language.Haskell.TH (Quote, Exp, listE)
+import Language.Haskell.TH.Syntax (Lift (..))
+import Control.Comonad.Cofree (Cofree(..))
+
+
+-- 뻘짓뻘짓뻘짓뻘짓뻘짓
+class Lift1 f where
+  liftLift :: Quote m => (a -> m Exp) -> f a -> m Exp
+
+lift1 :: (Lift1 f, Lift a, Quote m) => f a -> m Exp
+lift1 = liftLift lift
+
+
+--- instances
+
+instance Lift1 f => Lift1 (Cofree f) where
+  liftLift l (a :< e) = [|(:<) $(l a) $(liftLift (liftLift l) e)|]
+
+instance Lift1 List where
+  liftLift l xs = listE $ l <$> xs
+
+instance Lift1 NonEmpty where
+  liftLift l (x :| xs) = [|(:|) $(l x) $(liftLift l xs)|]

src/Gyehoek/Prelude.hs

@@ -21,7 +21,7 @@ module Gyehoek.Prelude
   , (<=<)
   ) where
 
-import Control.Lens hiding (List)
+import Control.Lens hiding (List, (:<))
 import Data.List (List)
 import Data.Text (Text)
 import Effectful

src/Gyehoek/Sexp/Grammar.hs

@@ -22,7 +22,7 @@ module Gyehoek.Sexp.Grammar
   where
 
 import Gyehoek.Sexp.Grammar.Base
-import Gyehoek.Prelude
+import Gyehoek.Prelude hiding (traversed, iso)
 import Data.InvertibleGrammar (backward, sealed, forward, runGrammar)
 import Gyehoek.Sexp.Print (printDatum, printDatum', printData)
 import Gyehoek.Jalmot
@@ -31,6 +31,7 @@ import qualified Gyehoek.Sexp.Read as Read
 import qualified Data.Text.IO as TIO
 import Text.Pretty.Simple (pPrintNoColor)
 import Data.InvertibleGrammar.Generic
+import qualified Control.Category
 
 
 toDatum :: Jalmot :> es => DatumGrammar a -> a -> Eff es Datum
@@ -95,3 +96,8 @@ instance DatumIso a => DatumIso (List a) where
 instance DatumIso Bool where datumIso = boolean
 
 instance DatumIso Int where datumIso = int
+
+instance DatumIso Datum where datumIso = Control.Category.id
+
+instance DatumIso a => DataIso (List a) where
+  dataIso = onHead . traversed . sealed $ datumIso @a

src/Gyehoek/Sexp/Print.hs

@@ -65,6 +65,7 @@ prettyDatum depth datum = case datum of
       Ordinary; NSpecial _ -> pparen depth $
         group . align . vsep $
           prettyDatum (depth+1) <$> xs
+  _ -> error [i|unimplemented: #{datum}|]
 
 pparen depth = enclose (delim depth "(") (delim depth ")")
 delim depth = annotate (SynParen depth)

src/Gyehoek/Sexp/QQ.hs

@@ -0,0 +1,128 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Gyehoek.Sexp.QQ
+  ( makeSxs
+  , makeSx
+  , makeSx'
+  , sx
+  , sxs
+  ) where
+
+import Data.Data (Typeable, cast)
+import Gyehoek.Prelude
+import Gyehoek.Sexp.Syntax
+import Language.Haskell.TH
+import qualified Data.Text as T
+import Data.List (groupBy)
+import Language.Haskell.TH.Syntax (liftData, Lift (lift))
+import Gyehoek.Jalmot
+import Gyehoek.Sexp.Grammar
+import Control.Exception (throw)
+import Language.Haskell.TH.Quote (QuasiQuoter(..))
+import Language.Haskell.TH.Syntax (dataToExpQ)
+import qualified Gyehoek.Sexp.Read as Read
+import Text.Megaparsec.Pos (mkPos)
+import Gyehoek.Lift1
+import Data.Foldable (toList)
+
+
+extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r
+extQ f g a = maybe (f a) g (cast a)
+
+spliceMeta :: (HasCallStack, DataIso a) => a -> List Datum
+spliceMeta x =
+  case runPureEff . runJalmot . toData dataIso $ x of
+    Left (cs,e) -> throw $ MkAJalmotCS cs e
+    Right xs -> xs
+
+meta :: (HasCallStack, DatumIso a) => a -> Datum
+meta x =
+  case runPureEff . runJalmot . toDatum datumIso $ x of
+    Left (cs,e) -> throw $ MkAJalmotCS cs e
+    Right xs -> xs
+
+unquoteSplicingRecursive :: List Datum -> ExpQ
+unquoteSplicingRecursive xs = [| mconcat $(spans) |]
+  where
+    spans = xs
+      & groupBy \cases
+          (MetaSplice _) _ -> False
+          _ (MetaSplice _) -> False
+          _ _              -> True
+      & fmap \case
+        [MetaSplice x] ->
+          [| spliceMeta $(varE (mkName (T.unpack x))) |]
+        es -> listE $ unquoteRecursive <$> es
+      & listE
+
+unquoteRecursive :: Datum -> ExpQ
+unquoteRecursive = \case
+  Meta x -> [| meta $(varE (mkName (T.unpack x))) |]
+  a :< CompoundF x -> [| $(liftData a) :< CompoundF $c|]
+    where
+      c = case x of
+        ListF ind xs ->
+          [| ListF $(lift ind) $(unquoteSplicingRecursive xs) |]
+        VectorF xs ->
+          [| VectorF $(unquoteSplicingRecursive xs) |]
+        DotListF xs t ->
+          [| DotListF $(liftLift unquoteRecursive xs) $(unquoteRecursive t) |]
+        AbbrevF p t ->
+          [| AbbrevF $(lift p) $(unquoteRecursive t) |]
+  e -> liftData e
+
+
+
+getPos :: Q SourcePos
+getPos = do
+  Loc {loc_filename,loc_start} <- location
+  pure $ SourcePos
+    { sourceName = loc_filename
+    , sourceLine = mkPos $ fst loc_start
+    , sourceColumn = mkPos $ snd loc_start
+    }
+
+readq
+  :: (SourcePos -> Text -> Eff '[Jalmot, IOE] a)
+  -> String -> Q a
+readq f s = do
+  pos <- getPos
+  liftIO . runJalmotIO . f pos . T.pack $ s
+
+makeSxs :: Data r => Code Q (List Datum -> r) -> QuasiQuoter
+makeSxs f = QuasiQuoter
+  { quoteExp = \str -> do
+      xs <- readq Read.readStringWithPos str
+      let e = dataToExpQ
+             (const Nothing
+              `extQ` (Just . unquoteRecursive)
+              `extQ` (Just . unquoteSplicingRecursive))
+             xs
+      [| $(unTypeCode f) $e |]
+  , quotePat = undefined
+  , quoteType = undefined
+  , quoteDec = undefined
+  }
+
+-- | An untyped variant of 'makeSx', useful when the user function is
+-- polymorphic in its return value.
+makeSx' :: ExpQ -> QuasiQuoter
+makeSx' f = QuasiQuoter
+  { quoteExp = \str -> do
+      x <- readq Read.readStringWithPos1 str
+      let e = dataToExpQ
+             (const Nothing
+              `extQ` (Just . unquoteRecursive)
+              `extQ` (Just . unquoteSplicingRecursive))
+             x
+      [| $f $e |]
+  , quotePat = undefined
+  , quoteType = undefined
+  , quoteDec = undefined
+  }
+
+makeSx :: Data r => Code Q (Datum -> r) -> QuasiQuoter
+makeSx = makeSx' . unTypeCode
+
+sx, sxs :: QuasiQuoter
+sxs = makeSxs [|| id @(List Datum) ||]
+sx = makeSx [|| id @Datum ||]

src/Gyehoek/Sexp/Read.hs

@@ -2,6 +2,9 @@ module Gyehoek.Sexp.Read
   ( readFile
   , readString
   , readString1
+  , SourcePos(..)
+  , readStringWithPos
+  , readStringWithPos1
   ) where
 
 import Text.Megaparsec
@@ -34,10 +37,48 @@ readString s =
 
 readString1 :: Jalmot :> es => Text -> Eff es Datum
 readString1 s = 
-  case runParser (sc *> datum <* eof) "<none>" s of
+  case runParser file1 "<none>" s of
     Right x -> pure x
     Left eb -> throwError . ReaderError $ eb
 
+initialStateFromSourcePos :: SourcePos -> s -> State s e
+initialStateFromSourcePos pos s = State
+  { stateInput = s
+  , stateOffset = 0
+  , stateParseErrors = []
+  , statePosState = PosState
+    { pstateInput = s
+    , pstateOffset = 0
+    , pstateSourcePos = pos
+    , pstateTabWidth = defaultTabWidth
+    , pstateLinePrefix = ""
+    }
+  }
+
+readStringWithPos1
+  :: Jalmot :> es
+  => SourcePos
+  -> Text
+  -> Eff es Datum
+readStringWithPos1 pos s =
+  case snd $ runParser' file1 st of
+    Right x -> pure x
+    Left eb -> throwError . ReaderError $ eb
+  where
+    st = initialStateFromSourcePos pos s
+
+readStringWithPos
+  :: Jalmot :> es
+  => SourcePos
+  -> Text
+  -> Eff es (List Datum)
+readStringWithPos pos s =
+  case snd $ runParser' file st of
+    Right x -> pure x
+    Left eb -> throwError . ReaderError $ eb
+  where
+    st = initialStateFromSourcePos pos s
+
 type P = Parsec Void Text
 
 
@@ -134,16 +175,19 @@ string = label "string" . lexeme $
 
 metaSplice :: P Text
 metaSplice = label "splicing meta" . lexeme . between "##{" "}" $
-  takeWhileP Nothing (/= '}')
+  takeWhile1P Nothing (/= '}')
 
 meta :: P Text
 meta = label "meta" . lexeme . between "#{" "}" $
-  takeWhileP Nothing (/= '}')
+  takeWhile1P Nothing (/= '}')
 
 
 
 file :: P (List Datum)
-file = many datum <* eof
+file = sc *> many datum <* eof
+
+file1 :: P Datum
+file1 = sc *> datum <* eof
 
 datum :: P Datum
 datum = do
@@ -153,6 +197,8 @@ datum = do
     , Simple <$> simpleDatum
     -- , labeled
     -- , labelRef
+    , MetaSplice <$> metaSplice
+    , Meta <$> meta
     ]
 
 simpleDatum :: P Simple
@@ -163,8 +209,6 @@ simpleDatum = choice
   , SimpleString <$> string
   , SimpleSymbol <$> symbol
   -- , SimpleBytevector <$> bytevector
-  , SimpleMetaSplice <$> metaSplice
-  , SimpleMeta <$> meta
   ]
 
 compoundDatum :: P Compound

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)|]

test/Gyehoek/Test/Sexp/QQ.hs

@@ -0,0 +1,47 @@
+module Gyehoek.Test.Sexp.QQ where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+import Gyehoek.Sexp.QQ (sx)
+import Data.Function (on)
+import Gyehoek.Sexp.Syntax
+import Data.Coerce (coerce)
+
+
+newtype EquivDatum = MkEquiv Datum
+  deriving newtype (Show)
+
+instance Eq EquivDatum where
+  (==) = (==) `on` (stripAnn . coerce)
+
+assertEquiv
+  :: HasCallStack
+  => String -> Datum -> Datum -> Assertion
+assertEquiv prefix = assertEqual prefix `on` MkEquiv
+
+equivto :: HasCallStack => Datum -> Datum -> Assertion
+equivto = assertEquiv ""
+
+test_qq :: TestTree
+test_qq = testGroup "sexp quasiquoter"
+  [ testCase "quotation" do
+      equivto (Symbol "abc") [sx|abc|]
+      equivto (List [Symbol "a", Symbol "b"]) [sx|(a b)|]
+  , testCase "antiquotation" do
+      equivto [sx|123|]
+        let meta = 123 :: Int
+        in [sx|#{meta}|]
+      equivto [sx|(blah (blah blah) blah)|]
+        let meta = [sx|blah|]
+        in [sx|(#{meta} (#{meta} #{meta}) #{meta})|]
+  , testCase "splicing simple" do
+      equivto [sx|(a b c d e f g)|]
+        let metas = Symbol <$> ["c","d","e"]
+        in [sx|(a b ##{metas} f g)|]
+  , testCase "splicing multiple" do
+      equivto [sx|(a (b c d) e f g)|]
+        let
+          e1 = Symbol "c"
+          e2 = Symbol <$> ["e","f"]
+        in [sx|(a (b #{e1} d) ##{e2} g)|]
+  ]