hls-splice-plugin 1.0.0.0 → 1.0.0.1

raw patch · 42 files changed

+621/−107 lines, 42 filesdep +directorydep +filepathdep +hls-splice-plugindep ~basedep ~ghcidedep ~hls-plugin-apiPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: directory, filepath, hls-splice-plugin, hls-test-utils

Dependency ranges changed: base, ghcide, hls-plugin-api

API changes (from Hackage documentation)

Files

• hls-splice-plugin.cabal +64/−30
• src/Ide/Plugin/Splice.hs +76/−64
• src/Ide/Plugin/Splice/Types.hs +13/−13
• test/Main.hs +135/−0
• test/testdata/QQ.hs +28/−0
• test/testdata/TDeclKindError.hs +15/−0
• test/testdata/TDeclKindError.hs.error +16/−0
• test/testdata/TDeclKindError.hs.expected +13/−0
• test/testdata/TErrorExp.hs +6/−0
• test/testdata/TErrorExp.hs.expected +6/−0
• test/testdata/TErrorPat.hs +6/−0
• test/testdata/TErrorPat.hs.expected +6/−0
• test/testdata/TQQDecl.hs +5/−0
• test/testdata/TQQDecl.hs.expected +6/−0
• test/testdata/TQQExp.hs +6/−0
• test/testdata/TQQExp.hs.expected +6/−0
• test/testdata/TQQExpError.hs +6/−0
• test/testdata/TQQExpError.hs.expected +6/−0
• test/testdata/TQQPat.hs +7/−0
• test/testdata/TQQPat.hs.expected +7/−0
• test/testdata/TQQPatError.hs +7/−0
• test/testdata/TQQPatError.hs.expected +7/−0
• test/testdata/TQQType.hs +9/−0
• test/testdata/TQQType.hs.expected +9/−0
• test/testdata/TQQTypeTypeError.hs +9/−0
• test/testdata/TQQTypeTypeError.hs.expected +9/−0
• test/testdata/TSimpleDecl.hs +15/−0
• test/testdata/TSimpleDecl.hs.expected +12/−0
• test/testdata/TSimpleExp.hs +6/−0
• test/testdata/TSimpleExp.hs.expected +6/−0
• test/testdata/TSimplePat.hs +6/−0
• test/testdata/TSimplePat.hs.expected +6/−0
• test/testdata/TSimpleType.hs +6/−0
• test/testdata/TSimpleType.hs.expected +6/−0
• test/testdata/TTypeAppExp.hs +7/−0
• test/testdata/TTypeAppExp.hs.expected +7/−0
• test/testdata/TTypeKindError.hs +8/−0
• test/testdata/TTypeKindError.hs.error +8/−0
• test/testdata/TTypeKindError.hs.expected +8/−0
• test/testdata/TTypeTypeError.hs +8/−0
• test/testdata/TTypeTypeError.hs.expected +8/−0
• test/testdata/hie.yaml +21/−0

@@ -1,39 +1,73 @@-cabal-version:      2.2
+cabal-version:      2.4
 name:               hls-splice-plugin
-version:            1.0.0.0
-synopsis:           HLS Plugin to expand TemplateHaskell Splices and QuasiQuotes
-description:        HLS Plugin to expand TemplateHaskell Splices and QuasiQuotes.
+version:            1.0.0.1
+synopsis:
+  HLS Plugin to expand TemplateHaskell Splices and QuasiQuotes
+
+description:
+  HLS Plugin to expand TemplateHaskell Splices and QuasiQuotes.
+
 license:            Apache-2.0
 license-file:       LICENSE
-author:             https://github.com/haskell/haskell-language-server/contributors
-maintainer:         https://github.com/haskell/haskell-language-server/contributors
+author:
+  https://github.com/haskell/haskell-language-server/contributors
+
+maintainer:
+  https://github.com/haskell/haskell-language-server/contributors
+
 category:           Development
 build-type:         Simple
+extra-source-files:
+  LICENSE
+  test/testdata/*.error
+  test/testdata/*.expected
+  test/testdata/*.hs
+  test/testdata/*.yaml
 
 library
-  exposed-modules:  Ide.Plugin.Splice
-  ghc-options:      -Wall -Wno-unticked-promoted-constructors
-  other-modules:    Ide.Plugin.Splice.Types
-  hs-source-dirs:   src
-  build-depends:    aeson
-                  , base                 >=4.12 && <5
-                  , containers
-                  , extra
-                  , foldl
-                  , lsp
-                  , hls-plugin-api       ^>= 1.0.0.0
-                  , ghc
-                  , ghc-exactprint
-                  , ghcide               ^>= 1.0.0.0
-                  , lens
-                  , dlist
-                  , retrie
-                  , shake
-                  , syb
-                  , text
-                  , transformers
-                  , unordered-containers
-                  , unliftio-core
+  exposed-modules:
+    Ide.Plugin.Splice
+    Ide.Plugin.Splice.Types
 
+  ghc-options:        -Wall -Wno-unticked-promoted-constructors
+  hs-source-dirs:     src
+  build-depends:
+    , aeson
+    , base                  >=4.12    && <5
+    , containers
+    , dlist
+    , extra
+    , foldl
+    , ghc
+    , ghc-exactprint
+    , ghcide                ^>=1.2
+    , hls-plugin-api        ^>=1.1
+    , lens
+    , lsp
+    , retrie
+    , shake
+    , syb
+    , text
+    , transformers
+    , unliftio-core
+    , unordered-containers
+
+  default-language:   Haskell2010
+  default-extensions:
+    DataKinds
+    TypeOperators
+
+test-suite tests
+  type:             exitcode-stdio-1.0
   default-language: Haskell2010
-  default-extensions: DataKinds, TypeOperators
+  hs-source-dirs:   test
+  main-is:          Main.hs
+  ghc-options:      -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+    , base
+    , directory
+    , extra
+    , filepath
+    , hls-splice-plugin
+    , hls-test-utils  ^>= 1.0
+    , text

@@ -1,60 +1,63 @@-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE DeriveDataTypeable    #-}
+{-# LANGUAGE DerivingStrategies    #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE MagicHash             #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TupleSections         #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE ViewPatterns          #-}
+{-# LANGUAGE NamedFieldPuns        #-}
 
 module Ide.Plugin.Splice
     ( descriptor,
     )
 where
 
-import Control.Applicative (Alternative ((<|>)))
-import Control.Arrow
-import qualified Control.Foldl as L
-import Control.Lens (ix, view, (%~), (<&>), (^.))
-import Control.Monad
-import Control.Monad.Extra (eitherM)
-import qualified Control.Monad.Fail as Fail
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.Except
-import Control.Monad.Trans.Maybe
-import Data.Aeson
-import Data.Function
-import Data.Generics
-import qualified Data.Kind as Kinds
-import Data.List (sortOn)
-import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
-import qualified Data.Text as T
-import Development.IDE
-import Development.IDE.GHC.Compat hiding (getLoc)
-import Exception
-import GHC.Exts
-import GhcMonad
-import GhcPlugins hiding (Var, getLoc, (<>))
-import Ide.Plugin.Splice.Types
-import Development.IDE.GHC.ExactPrint
-import Ide.Types
-import Language.Haskell.GHC.ExactPrint (setPrecedingLines, uniqueSrcSpanT)
-import Language.LSP.Server
-import Language.LSP.Types
-import Language.LSP.Types.Capabilities
-import qualified Language.LSP.Types.Lens as J
-import RnSplice
-import TcRnMonad
-import Data.Foldable (Foldable(foldl'))
-import Control.Monad.IO.Unlift
+import           Control.Applicative             (Alternative ((<|>)))
+import           Control.Arrow
+import qualified Control.Foldl                   as L
+import           Control.Lens                    (ix, view, (%~), (<&>), (^.), Identity(..))
+import           Control.Monad
+import           Control.Monad.Extra             (eitherM)
+import qualified Control.Monad.Fail              as Fail
+import           Control.Monad.IO.Unlift
+import           Control.Monad.Trans.Class
+import           Control.Monad.Trans.Except
+import           Control.Monad.Trans.Maybe
+import           Data.Aeson
+import           Data.Foldable                   (Foldable (foldl'))
+import           Data.Function
+import           Data.Generics
+import qualified Data.Kind                       as Kinds
+import           Data.List                       (sortOn)
+import           Data.Maybe                      (fromMaybe, listToMaybe,
+                                                  mapMaybe)
+import qualified Data.Text                       as T
+import           Development.IDE
+import           Development.IDE.GHC.Compat      hiding (getLoc)
+import           Development.IDE.GHC.ExactPrint
+import           Exception
+import           GHC.Exts
+import           GhcMonad
+import           GhcPlugins                      hiding (Var, getLoc, (<>))
+import           Ide.Plugin.Splice.Types
+import           Ide.Types
+import           Language.Haskell.GHC.ExactPrint (setPrecedingLines,
+                                                  uniqueSrcSpanT)
+import           Language.LSP.Server
+import           Language.LSP.Types
+import           Language.LSP.Types.Capabilities
+import qualified Language.LSP.Types.Lens         as J
+import           RnSplice
+import           TcRnMonad
 
 descriptor :: PluginId -> PluginDescriptor IdeState
 descriptor plId =
@@ -236,8 +239,8 @@     initializePlugins env dflags4
 
 adjustToRange :: Uri -> Range -> WorkspaceEdit -> WorkspaceEdit
-adjustToRange uri ran (WorkspaceEdit mhult mlt) =
-    WorkspaceEdit (adjustWS <$> mhult) (fmap adjustDoc <$> mlt)
+adjustToRange uri ran (WorkspaceEdit mhult mlt x) =
+    WorkspaceEdit (adjustWS <$> mhult) (fmap adjustDoc <$> mlt) x
     where
         adjustTextEdits :: Traversable f => f TextEdit -> f TextEdit
         adjustTextEdits eds =
@@ -246,12 +249,21 @@                         (L.premap (view J.range) L.minimum)
                         eds
              in adjustLine minStart <$> eds
+
+        adjustATextEdits :: Traversable f => f (TextEdit |? AnnotatedTextEdit) -> f (TextEdit |? AnnotatedTextEdit)
+        adjustATextEdits = fmap $ \case
+          InL t -> InL $ runIdentity $ adjustTextEdits (Identity t)
+          InR AnnotatedTextEdit{_range, _newText, _annotationId} ->
+            let oldTE = TextEdit{_range,_newText}
+              in let TextEdit{_range,_newText} = runIdentity $ adjustTextEdits (Identity oldTE)
+                in InR $ AnnotatedTextEdit{_range,_newText,_annotationId}
+
         adjustWS = ix uri %~ adjustTextEdits
         adjustDoc :: DocumentChange -> DocumentChange
         adjustDoc (InR es) = InR es
         adjustDoc (InL es)
             | es ^. J.textDocument . J.uri == uri =
-                InL $ es & J.edits %~ adjustTextEdits
+                InL $ es & J.edits %~ adjustATextEdits
             | otherwise = InL es
 
         adjustLine :: Range -> TextEdit -> TextEdit
@@ -280,25 +292,25 @@ 
 instance HasSplice HsExpr where
     matchSplice _ (HsSpliceE _ spl) = Just spl
-    matchSplice _ _ = Nothing
+    matchSplice _ _                 = Nothing
     expandSplice _ = fmap (first Right) . rnSpliceExpr
 
 instance HasSplice Pat where
     matchSplice _ (SplicePat _ spl) = Just spl
-    matchSplice _ _ = Nothing
+    matchSplice _ _                 = Nothing
     expandSplice _ = rnSplicePat
 
 
 instance HasSplice HsType where
     matchSplice _ (HsSpliceTy _ spl) = Just spl
-    matchSplice _ _ = Nothing
+    matchSplice _ _                  = Nothing
     expandSplice _ = fmap (first Right) . rnSpliceType
 
 classifyAST :: SpliceContext -> SpliceClass
 classifyAST = \case
-    Expr -> OneToOneAST @HsExpr proxy#
+    Expr   -> OneToOneAST @HsExpr proxy#
     HsDecl -> IsHsDecl
-    Pat -> OneToOneAST @Pat proxy#
+    Pat    -> OneToOneAST @Pat proxy#
     HsType -> OneToOneAST @HsType proxy#
 
 type ReportEditor = forall m. MonadIO m => MessageType -> [T.Text] -> m ()
@@ -382,7 +394,7 @@ 
 fromSearchResult :: SearchResult a -> Maybe a
 fromSearchResult (Here r) = Just r
-fromSearchResult _ = Nothing
+fromSearchResult _        = Nothing
 
 -- TODO: workaround when HieAst unavailable (e.g. when the module itself errors)
 -- TODO: Declaration Splices won't appear in HieAst; perhaps we must just use Parsed/Renamed ASTs?
@@ -403,7 +415,7 @@                             act = mkLspCommand plId cmdId title (Just [toJSON params])
                         pure $
                             InR $
-                                CodeAction title (Just CodeActionRefactorRewrite) Nothing Nothing Nothing Nothing (Just act)
+                                CodeAction title (Just CodeActionRefactorRewrite) Nothing Nothing Nothing Nothing (Just act) Nothing
 
             pure $ maybe mempty List mcmds
     where
@@ -419,7 +431,7 @@                         | RealSrcSpan spn `isSubspanOf` l ->
                             case expr of
                                 HsSpliceE {} -> Here (spLoc, Expr)
-                                _ -> Continue
+                                _            -> Continue
                     _ -> Stop
                 )
                 `extQ` \case
@@ -431,21 +443,21 @@                         | RealSrcSpan spn `isSubspanOf` l ->
                             case pat of
                                 SplicePat{} -> Here (spLoc, Pat)
-                                _ -> Continue
+                                _           -> Continue
                     _ -> Stop
                 `extQ` \case
                     (L l@(RealSrcSpan spLoc) ty :: LHsType GhcPs)
                         | RealSrcSpan spn `isSubspanOf` l ->
                             case ty of
                                 HsSpliceTy {} -> Here (spLoc, HsType)
-                                _ -> Continue
+                                _             -> Continue
                     _ -> Stop
                 `extQ` \case
                     (L l@(RealSrcSpan spLoc) decl :: LHsDecl GhcPs)
                         | RealSrcSpan spn `isSubspanOf` l ->
                             case decl of
                                 SpliceD {} -> Here (spLoc, HsDecl)
-                                _ -> Continue
+                                _          -> Continue
                     _ -> Stop
 
 -- | Like 'something', but performs top-down searching, cutoffs when 'Stop' received,

@@ -1,21 +1,21 @@-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass     #-}
+{-# LANGUAGE DeriveGeneric      #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE OverloadedStrings  #-}
 
 module Ide.Plugin.Splice.Types where
 
-import Data.Aeson (FromJSON, ToJSON)
-import Development.IDE (Uri)
-import GHC.Generics (Generic)
-import Development.IDE.GHC.Compat (RealSrcSpan)
-import qualified Data.Text as T
-import Ide.Types ( CommandId )
+import           Data.Aeson                 (FromJSON, ToJSON)
+import qualified Data.Text                  as T
+import           Development.IDE            (Uri)
+import           Development.IDE.GHC.Compat (RealSrcSpan)
+import           GHC.Generics               (Generic)
+import           Ide.Types                  (CommandId)
 
 -- | Parameter for the addMethods PluginCommand.
 data ExpandSpliceParams = ExpandSpliceParams
-    { uri :: Uri
-    , spliceSpan :: RealSrcSpan
+    { uri           :: Uri
+    , spliceSpan    :: RealSrcSpan
     , spliceContext :: SpliceContext
     }
     deriving (Show, Eq, Generic)
@@ -36,11 +36,11 @@     ]
 
 toExpandCmdTitle :: ExpandStyle -> T.Text
-toExpandCmdTitle Inplace = inplaceCmdName
+toExpandCmdTitle Inplace   = inplaceCmdName
 toExpandCmdTitle Commented = commentedCmdName
 
 toCommandId :: ExpandStyle -> CommandId
-toCommandId Inplace = expandInplaceId
+toCommandId Inplace   = expandInplaceId
 toCommandId Commented = expandCommentedId
 
 expandInplaceId, expandCommentedId :: CommandId

@@ -0,0 +1,135 @@+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE ViewPatterns          #-}
+
+module Main (main) where
+
+import           Control.Monad
+import           Data.List               (find)
+import           Data.Text               (Text)
+import qualified Data.Text               as T
+import qualified Data.Text.IO            as T
+import qualified Ide.Plugin.Splice       as Splice
+import           Ide.Plugin.Splice.Types
+import           System.Directory
+import           System.FilePath
+import           System.Time.Extra       (sleep)
+import           Test.Hls
+
+main :: IO ()
+main = defaultTestRunner tests
+
+plugin :: PluginDescriptor IdeState
+plugin = Splice.descriptor "splice"
+
+tests :: TestTree
+tests =
+    testGroup
+        "splice"
+        [ goldenTest "TSimpleExp.hs" Inplace 6 15
+        , goldenTest "TSimpleExp.hs" Inplace 6 24
+        , goldenTest "TTypeAppExp.hs" Inplace 7 5
+        , goldenTest "TErrorExp.hs" Inplace 6 15
+        , goldenTest "TErrorExp.hs" Inplace 6 51
+        , goldenTest "TQQExp.hs" Inplace 6 17
+        , goldenTest "TQQExp.hs" Inplace 6 25
+        , goldenTest "TQQExpError.hs" Inplace 6 13
+        , goldenTest "TQQExpError.hs" Inplace 6 22
+        , testGroup "Pattern Splices"
+            [ goldenTest "TSimplePat.hs" Inplace 6 3
+            , goldenTest "TSimplePat.hs" Inplace 6 22
+            , goldenTest "TSimplePat.hs" Inplace 6 3
+            , goldenTest "TSimplePat.hs" Inplace 6 22
+            , goldenTest "TErrorPat.hs" Inplace 6 3
+            , goldenTest "TErrorPat.hs" Inplace 6 18
+            , goldenTest "TQQPat.hs" Inplace 6 3
+            , goldenTest "TQQPat.hs" Inplace 6 11
+            , goldenTest "TQQPatError.hs" Inplace 6 3
+            , goldenTest "TQQPatError.hs" Inplace 6 11
+            ]
+        , goldenTest "TSimpleType.hs" Inplace 5 12
+        , goldenTest "TSimpleType.hs" Inplace 5 22
+        , goldenTest "TTypeTypeError.hs" Inplace 7 12
+        , goldenTest "TTypeTypeError.hs" Inplace 7 52
+        , goldenTest "TQQType.hs" Inplace 8 19
+        , goldenTest "TQQType.hs" Inplace 8 28
+        , goldenTest "TQQTypeTypeError.hs" Inplace 8 19
+        , goldenTest "TQQTypeTypeError.hs" Inplace 8 28
+        , goldenTest "TSimpleDecl.hs" Inplace 8 1
+        , goldenTest "TQQDecl.hs" Inplace 5 1
+        , goldenTestWithEdit "TTypeKindError.hs" Inplace 7 9
+        , goldenTestWithEdit "TDeclKindError.hs" Inplace 8 1
+        ]
+
+goldenTest :: FilePath -> ExpandStyle -> Int -> Int -> TestTree
+goldenTest input tc line col =
+    testCase (input <> " (golden)") $ do
+        runSessionWithServer plugin spliceTestPath $ do
+            doc <- openDoc input "haskell"
+            _ <- waitForDiagnostics
+            actions <- getCodeActions doc $ pointRange line col
+            case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of
+                Just (InR CodeAction {_command = Just c}) -> do
+                    executeCommand c
+                    _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit)
+                    edited <- documentContents doc
+                    let expected_name = input <.> "expected"
+                    -- Write golden tests if they don't already exist
+                    liftIO $
+                        (doesFileExist expected_name >>=) $
+                            flip unless $ do
+                                T.writeFile expected_name edited
+                    expected <- liftIO $ T.readFile expected_name
+                    liftIO $ edited @?= expected
+                _ -> liftIO $ assertFailure "No CodeAction detected"
+
+goldenTestWithEdit :: FilePath -> ExpandStyle -> Int -> Int -> TestTree
+goldenTestWithEdit input tc line col =
+    testCase (input <> " (golden)") $ do
+        runSessionWithServer plugin spliceTestPath $ do
+            doc <- openDoc input "haskell"
+            orig <- documentContents doc
+            let lns = T.lines orig
+                theRange =
+                    Range
+                        { _start = Position 0 0
+                        , _end = Position (length lns + 1) 1
+                        }
+            liftIO $ sleep 3
+            alt <- liftIO $ T.readFile (input <.> "error")
+            void $ applyEdit doc $ TextEdit theRange alt
+            changeDoc doc [TextDocumentContentChangeEvent (Just theRange) Nothing alt]
+            void waitForDiagnostics
+            actions <- getCodeActions doc $ pointRange line col
+            case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of
+                Just (InR CodeAction {_command = Just c}) -> do
+                    executeCommand c
+                    _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit)
+                    edited <- documentContents doc
+                    let expected_name = input <.> "expected"
+                    -- Write golden tests if they don't already exist
+                    liftIO $
+                        (doesFileExist expected_name >>=) $
+                            flip unless $ do
+                                T.writeFile expected_name edited
+                    expected <- liftIO $ T.readFile expected_name
+                    liftIO $ edited @?= expected
+                _ -> liftIO $ assertFailure "No CodeAction detected"
+
+spliceTestPath :: FilePath
+spliceTestPath = "test" </> "testdata"
+
+pointRange :: Int -> Int -> Range
+pointRange
+    (subtract 1 -> line)
+    (subtract 1 -> col) =
+        Range (Position line col) (Position line $ col + 1)
+
+-- | Get the title of a code action.
+codeActionTitle :: (Command |? CodeAction) -> Maybe Text
+codeActionTitle InL{}                               = Nothing
+codeActionTitle (InR(CodeAction title _ _ _ _ _ _ _)) = Just title

@@ -0,0 +1,28 @@+{-# LANGUAGE TemplateHaskell #-}
+module QQ (str) where
+
+import Language.Haskell.TH
+    ( mkName,
+      stringL,
+      litP,
+      clause,
+      litE,
+      normalB,
+      funD,
+      sigD,
+      litT,
+      strTyLit )
+import Language.Haskell.TH.Quote (QuasiQuoter (..))
+
+str :: QuasiQuoter
+str =
+    QuasiQuoter
+        { quoteExp = litE . stringL
+        , quotePat = litP . stringL
+        , quoteType = litT . strTyLit
+        , quoteDec = \name ->
+            sequence
+                [ sigD (mkName name) [t|String|]
+                , funD (mkName name) [clause [] (normalB $ litE $ stringL name) []]
+                ]
+        }

@@ -0,0 +1,15 @@+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+module TSimpleDecl where
+import Language.Haskell.TH ( mkName, clause, normalB, funD, sigD )
+
+-- Foo
+--  Bar
+$(sequence
+    [sigD (mkName "foo") [t|Int|]
+    ,funD (mkName "foo") [clause [] (normalB [|42|]) []]
+    ]
+    )
+-- Bar
+-- ee
+-- dddd

@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+module TSimpleDecl where
+import Language.Haskell.TH ( mkName, clause, normalB, funD, sigD )
+
+-- Foo
+--  Bar
+$(sequence
+    [sigD (mkName "foo") [t|Int|]
+    ,funD (mkName "foo") [clause [] (normalB [|42|]) []]
+    ,sigD (mkName "bar") [t|Int|]
+    ]
+    )
+-- Bar
+-- ee
+-- dddd

@@ -0,0 +1,13 @@+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+module TSimpleDecl where
+import Language.Haskell.TH ( mkName, clause, normalB, funD, sigD )
+
+-- Foo
+--  Bar
+foo :: Int
+foo = 42
+bar :: Int
+-- Bar
+-- ee
+-- dddd

@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}
+module TErrorExp where
+import Language.Haskell.TH ( tupE, litE, integerL )
+
+main :: IO ()
+main = return $(tupE [litE $ integerL 42, tupE []])

@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}
+module TErrorExp where
+import Language.Haskell.TH ( tupE, litE, integerL )
+
+main :: IO ()
+main = return (42, ())

@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}
+module TErrorPat where
+import Language.Haskell.TH ( conP )
+
+f :: () -> ()
+f $(conP 'True []) = x

@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}
+module TErrorPat where
+import Language.Haskell.TH ( conP )
+
+f :: () -> ()
+f True = x

@@ -0,0 +1,5 @@+{-# LANGUAGE QuasiQuotes #-}
+module TQQDecl where
+import QQ (str)
+
+[str|foo|]

@@ -0,0 +1,6 @@+{-# LANGUAGE QuasiQuotes #-}
+module TQQDecl where
+import QQ (str)
+
+foo :: String
+foo = "foo"

@@ -0,0 +1,6 @@+{-# LANGUAGE QuasiQuotes #-}
+module TQQExp where
+import QQ
+
+main :: IO ()
+main = putStrLn [str|str|]

@@ -0,0 +1,6 @@+{-# LANGUAGE QuasiQuotes #-}
+module TQQExp where
+import QQ
+
+main :: IO ()
+main = putStrLn "str"

@@ -0,0 +1,6 @@+{-# LANGUAGE QuasiQuotes #-}
+module TQQExpError where
+import QQ
+
+main :: IO ()
+main = pure [str|str|]

@@ -0,0 +1,6 @@+{-# LANGUAGE QuasiQuotes #-}
+module TQQExpError where
+import QQ
+
+main :: IO ()
+main = pure "str"

@@ -0,0 +1,7 @@+{-# LANGUAGE QuasiQuotes #-}
+module TQQPat where
+import QQ
+
+f :: String -> IO ()
+f [str|str|] = putStrLn "is str"
+f _ = putStrLn " not str"

@@ -0,0 +1,7 @@+{-# LANGUAGE QuasiQuotes #-}
+module TQQPat where
+import QQ
+
+f :: String -> IO ()
+f "str" = putStrLn "is str"
+f _ = putStrLn " not str"

@@ -0,0 +1,7 @@+{-# LANGUAGE QuasiQuotes #-}
+module TQQPatError where
+import QQ
+
+f :: () -> IO ()
+f [str|str|] = putStrLn "is str"
+f _ = putStrLn " not str"

@@ -0,0 +1,7 @@+{-# LANGUAGE QuasiQuotes #-}
+module TQQPatError where
+import QQ
+
+f :: () -> IO ()
+f "str" = putStrLn "is str"
+f _ = putStrLn " not str"

@@ -0,0 +1,9 @@+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE QuasiQuotes #-}
+module TQQType where
+import Language.Haskell.TH ( appT, numTyLit, litT, conT )
+import Data.Proxy ( Proxy(..) )
+import QQ
+
+main :: IO (Proxy [str|str|])
+main = return Proxy

@@ -0,0 +1,9 @@+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE QuasiQuotes #-}
+module TQQType where
+import Language.Haskell.TH ( appT, numTyLit, litT, conT )
+import Data.Proxy ( Proxy(..) )
+import QQ
+
+main :: IO (Proxy "str")
+main = return Proxy

@@ -0,0 +1,9 @@+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE QuasiQuotes #-}
+module TQQTypeTypeError where
+import Language.Haskell.TH ( appT, numTyLit, litT, conT )
+import Data.Proxy ( Proxy(..) )
+import QQ
+
+main :: IO (Proxy [str|str|])
+main = return ()

@@ -0,0 +1,9 @@+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE QuasiQuotes #-}
+module TQQTypeTypeError where
+import Language.Haskell.TH ( appT, numTyLit, litT, conT )
+import Data.Proxy ( Proxy(..) )
+import QQ
+
+main :: IO (Proxy "str")
+main = return ()

@@ -0,0 +1,15 @@+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+module TSimpleDecl where
+import Language.Haskell.TH ( mkName, clause, normalB, funD, sigD )
+
+-- Foo
+--  Bar
+$(sequence
+    [sigD (mkName "foo") [t|Int|]
+    ,funD (mkName "foo") [clause [] (normalB [|42|]) []]
+    ]
+    )
+-- Bar
+-- ee
+-- dddd

@@ -0,0 +1,12 @@+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+module TSimpleDecl where
+import Language.Haskell.TH ( mkName, clause, normalB, funD, sigD )
+
+-- Foo
+--  Bar
+foo :: Int
+foo = 42
+-- Bar
+-- ee
+-- dddd

@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}
+module TSimpleExp where
+import Language.Haskell.TH ( tupE, litE, integerL )
+
+main :: IO ()
+main = return $(tupE [])

@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}
+module TSimpleExp where
+import Language.Haskell.TH ( tupE, litE, integerL )
+
+main :: IO ()
+main = return ()

@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}
+module TSimplePat where
+import Language.Haskell.TH ( varP, mkName )
+
+f :: x -> x
+f $(varP $ mkName "x") = x

@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}
+module TSimplePat where
+import Language.Haskell.TH ( varP, mkName )
+
+f :: x -> x
+f x = x

@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}
+module TSimpleType where
+import Language.Haskell.TH ( tupleT )
+
+main :: IO $(tupleT 0)
+main = return ()

@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}
+module TSimpleType where
+import Language.Haskell.TH ( tupleT )
+
+main :: IO ()
+main = return ()

@@ -0,0 +1,7 @@+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+module TTypeAppExp where
+import Data.Proxy
+
+f :: Proxy Int
+f = $([|Proxy @Int|])

@@ -0,0 +1,7 @@+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+module TTypeAppExp where
+import Data.Proxy
+
+f :: Proxy Int
+f = (Proxy @Int)

@@ -0,0 +1,8 @@+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+module TTypeKindError where
+import Language.Haskell.TH ( numTyLit, litT )
+import Data.Proxy ( Proxy )
+
+main :: IO ()
+main = return ()

@@ -0,0 +1,8 @@+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+module TTypeKindError where
+import Language.Haskell.TH ( numTyLit, litT )
+import Data.Proxy ( Proxy )
+
+main :: $(litT (numTyLit 42))
+main = return ()

@@ -0,0 +1,8 @@+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+module TTypeKindError where
+import Language.Haskell.TH ( numTyLit, litT )
+import Data.Proxy ( Proxy )
+
+main :: (42)
+main = return ()

@@ -0,0 +1,8 @@+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+module TTypeTypeError where
+import Language.Haskell.TH ( appT, numTyLit, litT, conT )
+import Data.Proxy ( Proxy )
+
+main :: IO $(conT ''Proxy `appT` litT (numTyLit 42))
+main = return ()

@@ -0,0 +1,8 @@+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+module TTypeTypeError where
+import Language.Haskell.TH ( appT, numTyLit, litT, conT )
+import Data.Proxy ( Proxy )
+
+main :: IO (Proxy 42)
+main = return ()

@@ -0,0 +1,21 @@+cradle:
+  direct:
+    arguments:
+    - QQ.hs
+    - TQQExpError.hs
+    - TSimpleExp.hs
+    - TTypeAppExp.hs
+    - TDeclKindError.hs
+    - TQQPat.hs
+    - TSimplePat.hs
+    - TErrorExp.hs
+    - TQQPatError.hs
+    - TSimpleType.hs
+    - TErrorPat.hs
+    - TQQType.hs
+    - TTypeKindError.hs
+    - TQQDecl.hs
+    - TQQTypeTypeError.hs
+    - TTypeTypeError.hs
+    - TQQExp.hs
+    - TSimpleDecl.hs