exon 1.5.0.1 → 1.6.0.0

raw patch · 18 files changed

+638/−164 lines, 18 filesdep +ghcdep +parsecdep −flatparsedep −generics-sopdep −ghc-hs-metaPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc, parsec

Dependencies removed: flatparse, generics-sop, ghc-hs-meta

API changes (from Hackage documentation)

Files

• changelog.md +4/−0
• exon.cabal +6/−4
• lib/Exon.hs +1/−1
• lib/Exon/Class/Exon.hs +21/−21
• lib/Exon/Class/Newtype.hs +5/−7
• lib/Exon/Class/ToSegment.hs +6/−12
• lib/Exon/Combinators.hs +1/−1
• lib/Exon/Data/RawSegment.hs +2/−2
• lib/Exon/Data/Result.hs +2/−2
• lib/Exon/Data/Segment.hs +2/−2
• lib/Exon/Generic.hs +54/−33
• lib/Exon/Haskell/Parse.hs +121/−0
• lib/Exon/Haskell/Settings.hs +85/−0
• lib/Exon/Haskell/Translate.hs +236/−0
• lib/Exon/Parse.hs +71/−65
• lib/Exon/Quote.hs +7/−7
• lib/Exon/SkipWs.hs +5/−5
• test/Exon/Test/NewtypeTest.hs +9/−2

@@ -1,3 +1,7 @@+# 1.6.0.0++* Replace `flatparse` with `parsec` for less friction when updating GHC.+ # 1.5.0.0  * Use `exonProcess` for `intercalate`

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           exon-version:        1.5.0.1+version:        1.6.0.0 synopsis:       Customizable quasiquote interpolation description:    See https://hackage.haskell.org/package/exon/docs/Exon.html category:       String@@ -36,6 +36,9 @@       Exon.Data.Result       Exon.Data.Segment       Exon.Generic+      Exon.Haskell.Parse+      Exon.Haskell.Settings+      Exon.Haskell.Translate       Exon.Parse       Exon.Quote       Exon.SkipWs@@ -79,10 +82,9 @@   ghc-options: -Wall -Widentities -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wredundant-constraints -Wunused-type-patterns -Wunused-packages   build-depends:       base ==4.*-    , flatparse >=0.4 && <0.6-    , generics-sop >=0.5.1.1 && <0.6-    , ghc-hs-meta ==0.1.*+    , ghc     , incipit-base >=0.4 && <0.6+    , parsec     , template-haskell   mixins:       base hiding (Prelude)

@@ -1,4 +1,4 @@--- |Customizable Quasiquote Interpolation+-- | Customizable Quasiquote Interpolation module Exon (   -- * Introduction   -- $intro

@@ -1,4 +1,4 @@--- |Description: Internal+-- | Description: Internal module Exon.Class.Exon where  import qualified Data.ByteString.Builder as ByteString@@ -11,7 +11,7 @@ import qualified Exon.Data.Segment as Segment import Exon.Data.Segment (Segment) --- |Wrapping a quote type with this causes @a@ to be used irrespective of whether it is an unwrappable newtype.+-- | Wrapping a quote type with this causes @a@ to be used irrespective of whether it is an unwrappable newtype. -- -- @since 1.0.0.0 newtype ExonUse a =@@ -22,14 +22,14 @@ exonUse :: ExonUse a -> a exonUse = coerce --- |This class converts a segment into a builder.+-- | This class converts a segment into a builder. -- -- A builder is an auxiliary data type that may improve performance when concatenating segments, like 'Text.Builder'. -- The default instance uses no builder and is implemented as 'id'. -- -- @since 1.0.0.0 class ExonBuilder (inner :: Type) (builder :: Type) | inner -> builder where-  -- |Construct a builder from the newtype-unwrapped result type.+  -- | Construct a builder from the newtype-unwrapped result type.   exonBuilder :: inner -> builder    default exonBuilder :: inner ~ builder => inner -> builder@@ -37,7 +37,7 @@     id   {-# inline exonBuilder #-} -  -- |Convert the result of the builder concatenation back to the newtype-unwrapped result type.+  -- | Convert the result of the builder concatenation back to the newtype-unwrapped result type.   exonBuilderExtract :: Result builder -> inner    default exonBuilderExtract ::@@ -94,7 +94,7 @@     foldMap toLazyByteString   {-# inline exonBuilderExtract #-} --- |This class generalizes 'IsString' for use in 'ExonSegment'.+-- | This class generalizes 'IsString' for use in 'ExonSegment'. -- -- When a plain text segment (not interpolated) is processed, it is converted to the result type, which usually happens -- via 'fromString'.@@ -104,7 +104,7 @@ -- -- @since 1.0.0.0 class ExonString (result :: Type) (builder :: Type) where-  -- |Convert a 'String' to the builder type.+  -- | Convert a 'String' to the builder type.   exonString :: String -> Result builder    default exonString :: IsString builder => String -> Result builder@@ -112,7 +112,7 @@     Result . fromString   {-# inline exonString #-} -  -- |Convert a 'String' containing whitespace to the builder type.+  -- | Convert a 'String' containing whitespace to the builder type.   -- This is only used by whitespace-aware quoters, like 'Exon.exonws' or 'Exon.intron'.   exonWhitespace :: String -> Result builder @@ -123,18 +123,18 @@  instance {-# overlappable #-} IsString a => ExonString result a where --- |The instance for the type used by 'Text.Show.showsPrec'.+-- | The instance for the type used by 'Text.Show.showsPrec'. instance ExonString result (String -> String) where   exonString =     Result . showString   {-# inline exonString #-} --- |This class allows manipulation of interpolated expressions before they are processed, for example to replace empty+-- | This class allows manipulation of interpolated expressions before they are processed, for example to replace empty -- strings with 'Empty' for the purpose of collapsing multiple whitespaces. -- -- The default instance does nothing. class ExonExpression (result :: Type) (inner :: Type) (builder :: Type) where-  -- |Process a builder value constructed from an expression before concatenation.+  -- | Process a builder value constructed from an expression before concatenation.   exonExpression :: (inner -> builder) -> inner -> Result builder   exonExpression builder =     Result . builder@@ -142,7 +142,7 @@  instance {-# overlappable #-} ExonExpression result inner builder where --- |This class converts a 'Segment' to a builder.+-- | This class converts a 'Segment' to a builder. -- -- The default implementation performs the following conversions for the different segment variants: --@@ -158,7 +158,7 @@ -- -- @since 1.0.0.0 class ExonSegment (result :: Type) (inner :: Type) (builder :: Type) where-  -- |Convert literal string segments to the result type.+  -- | Convert literal string segments to the result type.   exonSegment :: (inner -> builder) -> Segment inner -> Result builder  instance {-# overlappable #-} (@@ -174,14 +174,14 @@         exonWhitespace @result a     {-# inline exonSegment #-} --- |This class handles concatenation of segments, which might be a builder or the result type.+-- | This class handles concatenation of segments, which might be a builder or the result type. -- -- The default instance simply uses '(<>)', and there is only one special instance for @'String' -> 'String'@, the type -- used by 'Text.Show.showsPrec'. -- -- @since 1.0.0.0 class ExonAppend (result :: Type) (builder :: Type) where-  -- |Concatenate two segments of the builder type.+  -- | Concatenate two segments of the builder type.   exonAppend :: builder -> builder -> Result builder    default exonAppend :: Semigroup builder => builder -> builder -> Result builder@@ -189,7 +189,7 @@     Result (z <> a)   {-# inline exonAppend #-} -  -- |Concatenate a list of segments of the result type.+  -- | Concatenate a list of segments of the result type.   --   -- Folds the list over 'exonAppend', skipping over 'Empty' segments.   --@@ -216,7 +216,7 @@     Result (z . a)   {-# inline exonAppend #-} --- |This class implements the 'Segment' concatenation logic.+-- | This class implements the 'Segment' concatenation logic. -- -- 1. Each 'Segment' is converted to the builder type by 'ExonSegment' using 'exonBuilder' to construct the builder from --    expressions.@@ -227,7 +227,7 @@ -- -- @since 1.0.0.0 class ExonBuild (result :: Type) (inner :: Type) where-  -- |Concatenate a list of 'Segment's.+  -- | Concatenate a list of 'Segment's.   exonBuild :: NonEmpty (Segment inner) -> inner  instance {-# overlappable #-} (@@ -241,13 +241,13 @@     fmap (exonSegment @result exonBuilder)   {-# inline exonBuild #-} --- |This class is the main entry point for Exon.+-- | This class is the main entry point for Exon. -- -- The default instance unwraps all newtypes that are 'Generic' and passes the innermost type to 'ExonBuild'. -- -- The original type is also used as a parameter to 'ExonBuild', so customizations can be based on it. class Exon (result :: Type) where-  -- |Concatenate a list of 'Segment's.+  -- | Concatenate a list of 'Segment's.   --   -- @since 1.0.0.0   exonProcess :: NonEmpty (Segment result) -> result@@ -260,7 +260,7 @@       overNewtypes @result (exonBuild @result)     {-# inline exonProcess #-} --- |Call 'exonProcess', but unwrap the arguments and rewrap the result using the supplied functions.+-- | Call 'exonProcess', but unwrap the arguments and rewrap the result using the supplied functions. -- -- @since 1.0.0.0 exonProcessWith ::

@@ -1,11 +1,11 @@--- |Description: Internal+-- | Description: Internal module Exon.Class.Newtype where  import Exon.Data.Segment (Segment) import Exon.Generic (IsNewtype, OverNt) import Unsafe.Coerce (unsafeCoerce) --- |Internal auxiliary class that applies a function to the value inside of a nested chain of 'Generic' newtypes.+-- | Internal auxiliary class that applies a function to the value inside of a nested chain of 'Generic' newtypes. class OverNewtype (current :: Type) (wrapped :: Maybe Type) (inner :: Type) | current -> inner where   overNewtype :: (NonEmpty (Segment inner) -> inner) -> NonEmpty (Segment current) -> current @@ -19,11 +19,10 @@     {-# inline overNewtype #-}  instance OverNewtype current 'Nothing current where-  overNewtype =-    id+  overNewtype = id   {-# inline overNewtype #-} --- |Internal auxiliary class that applies a function to the value inside of a nested chain of 'Generic' newtypes.+-- | Internal auxiliary class that applies a function to the value inside of a nested chain of 'Generic' newtypes. -- -- The method only passes its arguments to 'overNewtypes', but the class hides the intermediate parameter. class OverNewtypes (result :: Type) (inner :: Type) | result -> inner where@@ -33,6 +32,5 @@     IsNewtype result wrapped,     OverNewtype result wrapped inner   ) => OverNewtypes result inner where-    overNewtypes =-      overNewtype @result @wrapped+    overNewtypes = overNewtype @result @wrapped     {-# inline overNewtypes #-}

@@ -1,25 +1,20 @@ {-# options_haddock prune #-} --- |Description: Internal+-- | Description: Internal module Exon.Class.ToSegment where  import GHC.TypeLits (ErrorMessage)-import Generics.SOP (I (I), NP (Nil, (:*)), SOP (SOP), unZ)-import Generics.SOP.GGP (GCode, GFrom, gfrom) -import Exon.Generic (IsNewtype)+import Exon.Generic (IsNewtype, Unwrap (unwrap))  class NewtypeSegment (wrapped :: Maybe Type) a b where   newtypeSegment :: a -> b  instance (-    Generic a,-    GFrom a,-    GCode a ~ '[ '[b]],+    Unwrap a b,     ToSegment b c   ) => NewtypeSegment ('Just b) a c where-    newtypeSegment (gfrom -> SOP (unZ -> I b :* Nil)) =-      toSegment b+    newtypeSegment = toSegment . unwrap  type family Q (a :: k) :: ErrorMessage where   Q a = "‘" <> a <> "’"@@ -38,10 +33,9 @@     NoGenericMessage a b,     a ~ b   ) => NewtypeSegment 'Nothing a b where-  newtypeSegment =-    id+    newtypeSegment = id --- |This class determines how an expression is converted to an interpolation quote's result type.+-- | This class determines how an expression is converted to an interpolation quote's result type. -- -- For a quote like @[exon|a #{exp :: T} c|] :: R@, the instance @ToSegment T R@ is used to turn @T@ into @R@. -- Aside from specialized instances for stringly types, the default implementation uses 'Generic' to unwrap newtypes

@@ -1,4 +1,4 @@--- |Description: Internal+-- | Description: Internal module Exon.Combinators where  import qualified Data.List.NonEmpty as NonEmpty

@@ -1,8 +1,8 @@--- |Description: Data Type 'RawSegment', Internal+-- | Description: Data Type 'RawSegment', Internal  module Exon.Data.RawSegment where --- |An intermediate representation for internal use.+-- | An intermediate representation for internal use. data RawSegment =   WsSegment String   |

@@ -1,7 +1,7 @@--- |Description: Internal+-- | Description: Internal module Exon.Data.Result where --- |The combined segments, either empty or a value.+-- | The combined segments, either empty or a value. data Result a =   Empty   |

@@ -1,7 +1,7 @@--- |Description: Data Type 'Segment'+-- | Description: Data Type 'Segment' module Exon.Data.Segment where --- |The parts of an interpolation quasiquote.+-- | The parts of an interpolation quasiquote. -- Text is split at each whitespace and interpolation splice marked by @#{@ and @}@. data Segment a =   String String

@@ -1,46 +1,67 @@ {-# options_haddock prune #-} --- |Description: Internal+-- | Description: Internal module Exon.Generic where -import Generics.SOP (All2, I (I), NP (Nil, (:*)), NS (S, Z), SOP (SOP), Top)-import Generics.SOP.GGP (GCode, GDatatypeInfoOf, GFrom, GTo, gfrom, gto)-import Generics.SOP.Type.Metadata (DatatypeInfo (Newtype))+import GHC.Generics (C1, D1, K1 (K1), M1 (M1), Meta (MetaData), Rep, S1, from, to) -type ReifySOP (a :: Type) (ass :: [[Type]]) =-  (Generic a, GTo a, GCode a ~ ass, All2 Top ass)+type family PrepRep (rep :: Type -> Type) :: Maybe Type where+  PrepRep (D1 ('MetaData _ _ _ 'True) (C1 _ (S1 _ (K1 _ w)))) = 'Just w+  PrepRep (D1 ('MetaData _ _ _ 'True) (C1 _ (K1 _ w))) = 'Just w -type ConstructSOP (a :: Type) (ass :: [[Type]]) =-  (Generic a, GFrom a, GCode a ~ ass, All2 Top ass)+class RepIsNewtype (rep :: Maybe Type) (wrapped :: Maybe Type) | rep -> wrapped+instance {-# incoherent #-} wrapped ~ 'Nothing => RepIsNewtype rep wrapped+instance wrapped ~ 'Just w => RepIsNewtype ('Just w) wrapped -type ReifyNt (a :: Type) (b :: Type) =-  ReifySOP a '[ '[b] ]+class IsNewtype w (wrapped :: Maybe Type) | w -> wrapped+instance RepIsNewtype (PrepRep (Rep w)) wrapped => IsNewtype w wrapped -type GenNt (a :: Type) (b :: Type) =-  ConstructSOP a '[ '[b] ]+type NewtypeRep :: Symbol -> Symbol -> Symbol -> Meta -> Type -> Type -> Type -> Type+type NewtypeRep n m p c i w =+  D1 ('MetaData n m p 'True) (S1 c (K1 i w)) -type OverNt (a :: Type) (b :: Type) =-  (ReifyNt a b, GenNt a b)+class UnwrapField (rep :: Type -> Type) (w :: Type) | rep -> w where+  unwrapField :: rep x -> w -unwrap ::-  GenNt a b =>-  a ->-  b-unwrap a =-  case gfrom a of-    SOP (Z (I b :* Nil)) -> b-    SOP (S n) -> case n of+-- | Record selector+instance UnwrapField (S1 s (K1 i w)) w where+  unwrapField (M1 (K1 w)) = w -wrap ::-  ReifyNt a b =>-  b ->-  a-wrap b =-  gto (SOP (Z (I b :* Nil)))+-- | Plain field+instance UnwrapField (K1 i w) w where+  unwrapField (K1 w) = w -class GDatatypeInfoIsNewtype (dss :: [[Type]]) (info :: DatatypeInfo) (wrapped :: Maybe Type) | dss info -> wrapped-instance {-# incoherent #-} wrapped ~ 'Nothing => GDatatypeInfoIsNewtype dss info wrapped-instance wrapped ~ 'Just d => GDatatypeInfoIsNewtype '[ '[d]] ('Newtype m n c) wrapped+class Unwrap (a :: Type) (w :: Type) | a -> w where+  unwrap :: a -> w -class IsNewtype d (wrapped :: Maybe Type) | d -> wrapped-instance GDatatypeInfoIsNewtype (GCode d) (GDatatypeInfoOf d) wrapped => IsNewtype d wrapped+-- | Constructor ('C1') in a data type ('D1') that's a newtype (@'True@)+instance (+    Generic a,+    Rep a ~ D1 ('MetaData n m p 'True) (C1 c field),+    UnwrapField field w+  ) => Unwrap a w where+    unwrap (from -> M1 (M1 field)) = unwrapField field++class WrapField (rep :: Type -> Type) (w :: Type) | rep -> w where+  wrapField :: w -> rep x++-- | Record selector+instance WrapField (S1 s (K1 i w)) w where+  wrapField = M1 . K1++-- | Plain field+instance WrapField (K1 i w) w where+  wrapField = K1++class Wrap (a :: Type) (w :: Type) | a -> w where+  wrap :: w -> a++instance (+    Generic a,+    Rep a ~ D1 ('MetaData n m p 'True) (C1 c field),+    WrapField field w+  ) => Wrap a w where+    wrap w = to (M1 (M1 (wrapField w)))++type OverNt (a :: Type) (w :: Type) =+  (Wrap a w, Unwrap a w)

@@ -0,0 +1,121 @@+{-# LANGUAGE CPP #-}++-- | This module is here to parse Haskell expression using the GHC Api+--+-- Stolen from ghc-hs-meta+module Exon.Haskell.Parse (parseExp, parseExpWithExts, parseExpWithFlags, parseHsExpr) where++import Prelude hiding (srcLoc)++#if MIN_VERSION_ghc(9,4,0)+import GHC.Parser.Errors.Ppr ()+import GHC.Parser.Annotation (LocatedA)+import GHC.Utils.Outputable (ppr, defaultSDocContext, renderWithContext)+#else+import qualified GHC.Parser.Errors.Ppr as ParserErrorPpr+import GHC.Parser.Annotation (LocatedA)+#endif++#if MIN_VERSION_ghc(9,4,0)+import GHC.Driver.Config.Parser (initParserOpts)+#else+import GHC.Driver.Config (initParserOpts)+#endif++import GHC.Parser.PostProcess+import qualified GHC.Types.SrcLoc as SrcLoc+import GHC.Driver.Session+import GHC.Data.StringBuffer+import GHC.Parser.Lexer+import qualified GHC.Parser.Lexer as Lexer+import qualified GHC.Parser as Parser+import GHC.Data.FastString+import GHC.Types.SrcLoc++import GHC.Hs.Extension (GhcPs)++-- @HsExpr@ is available from GHC.Hs.Expr in all versions we support.+-- However, the goal of GHC is to split HsExpr into its own package, under+-- the namespace Language.Haskell.Syntax. The module split happened in 9.0,+-- but still in the ghc package.+import Language.Haskell.Syntax (HsExpr(..))++import Language.Haskell.TH (Extension(..))+import qualified Language.Haskell.TH.Syntax as TH++import qualified Exon.Haskell.Settings as Settings+import Exon.Haskell.Translate (toExp)++-- | Parse a Haskell expression from source code into a Template Haskell expression.+-- See @parseExpWithExts@ or @parseExpWithFlags@ for customizing with additional extensions and settings.+parseExp :: String -> Either (Int, Int, String) TH.Exp+#if MIN_VERSION_ghc(9,2,0)+parseExp = parseExpWithExts+    [ TypeApplications+    , OverloadedRecordDot+    , OverloadedLabels+    , OverloadedRecordUpdate+    ]+#else+parseExp = parseExpWithExts+    [ TypeApplications+    , OverloadedLabels+    ]+#endif++-- | Parse a Haskell expression from source code into a Template Haskell expression+-- using a given set of GHC extensions.+parseExpWithExts :: [Extension] -> String -> Either (Int, Int, String) TH.Exp+parseExpWithExts exts = parseExpWithFlags (Settings.baseDynFlags exts)++-- | Parse a Haskell expression from source code into a Template Haskell expression+-- using a given set of GHC DynFlags.+parseExpWithFlags :: DynFlags -> String -> Either (Int, Int, String) TH.Exp+parseExpWithFlags flags expStr = do+  hsExpr <- parseHsExpr flags expStr+  pure (toExp flags hsExpr)++-- | Run the GHC parser to parse a Haskell expression into a @HsExpr@.+parseHsExpr :: DynFlags -> String -> Either (Int, Int, String) (HsExpr GhcPs)+parseHsExpr dynFlags s =+  case runParser dynFlags s of+    POk _ locatedExpr ->+      let expr = SrcLoc.unLoc locatedExpr+       in Right+            expr++{- ORMOLU_DISABLE #-}+#if MIN_VERSION_ghc(9,4,0)+    PFailed PState{loc=SrcLoc.psRealLoc -> srcLoc, errors=errorMessages} ->+            let+                err = renderWithContext defaultSDocContext (ppr errorMessages)+                line = SrcLoc.srcLocLine srcLoc+                col = SrcLoc.srcLocCol srcLoc+            in Left (line, col, err)+#else+    PFailed PState{loc=SrcLoc.psRealLoc -> srcLoc, errors=errorMessages} ->+            let+                psErrToString e = show $ ParserErrorPpr.pprError e+                err = concatMap psErrToString errorMessages+                -- err = concatMap show errorMessages+                line = SrcLoc.srcLocLine srcLoc+                col = SrcLoc.srcLocCol srcLoc+            in Left (line, col, err)+#endif++-- From Language.Haskell.GhclibParserEx.GHC.Parser++parse :: P a -> String -> DynFlags -> ParseResult a+parse p str flags =+  Lexer.unP p parseState+  where+    location = mkRealSrcLoc (mkFastString "<string>") 1 1+    strBuffer = stringToStringBuffer str+    parseState =+      initParserState (initParserOpts flags) strBuffer location++runParser :: DynFlags -> String -> ParseResult (LocatedA (HsExpr GhcPs))+runParser flags str =+  case parse Parser.parseExpression str flags of+    POk s e -> unP (runPV (unECP e)) s+    PFailed ps -> PFailed ps

@@ -0,0 +1,85 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-missing-fields -Wno-name-shadowing -Wno-unused-imports #-}++-- | Settings needed for running the GHC Parser.+module Exon.Haskell.Settings (baseDynFlags) where++import Data.Data hiding (Fixity)+import Data.Maybe+import GHC.Data.FastString+import GHC.Data.StringBuffer+import GHC.Driver.Backpack.Syntax+import GHC.Driver.Config+import GHC.Driver.Session+import GHC.Hs+import qualified GHC.Parser as Parser+import GHC.Parser.Lexer+import qualified GHC.Parser.Lexer as Lexer+import GHC.Parser.PostProcess+import GHC.Platform+import GHC.Settings+import GHC.Settings.Config+import GHC.Types.Fixity+import GHC.Types.Name+import GHC.Types.Name.Reader+import GHC.Types.SourceText+import GHC.Types.SrcLoc+import GHC.Unit.Info+import GHC.Utils.Fingerprint+import qualified Language.Haskell.TH.Syntax as GhcTH++fakeSettings :: Settings+fakeSettings = Settings+  { sGhcNameVersion=ghcNameVersion+  , sFileSettings=fileSettings+  , sTargetPlatform=platform+  , sPlatformMisc=platformMisc+  , sToolSettings=toolSettings+  }+  where+    toolSettings = ToolSettings {+      toolSettings_opt_P_fingerprint=fingerprint0+      }+    fileSettings = FileSettings {}+    platformMisc = PlatformMisc {}+    ghcNameVersion =+      GhcNameVersion{ghcNameVersion_programName="ghc"+                    ,ghcNameVersion_projectVersion=cProjectVersion+                    }+    platform =+      Platform{+    -- It doesn't matter what values we write here as these fields are+    -- not referenced for our purposes. However the fields are strict+    -- so we must say something.+        platformByteOrder=LittleEndian+      , platformHasGnuNonexecStack=True+      , platformHasIdentDirective=False+      , platformHasSubsectionsViaSymbols=False+      , platformIsCrossCompiling=False+      , platformLeadingUnderscore=False+      , platformTablesNextToCode=False+      , platform_constants=platformConstants+      ,++        platformWordSize=PW8+      , platformArchOS=ArchOS {archOS_arch=ArchUnknown, archOS_OS=OSUnknown}++#if MIN_VERSION_ghc(9, 4, 0)+      , platformHasLibm = False+#endif+      , platformUnregisterised=True+      }+    platformConstants = Nothing++#if MIN_VERSION_ghc(9, 6, 0)+applyFakeLlvmConfig :: a -> a+applyFakeLlvmConfig = id+#else+applyFakeLlvmConfig :: (LlvmConfig -> a) -> a+applyFakeLlvmConfig f = f $ LlvmConfig [] []+#endif++baseDynFlags :: [GhcTH.Extension] -> DynFlags+baseDynFlags exts =+  let enable = GhcTH.TemplateHaskellQuotes : exts+   in foldl xopt_set (applyFakeLlvmConfig (defaultDynFlags fakeSettings)) enable

@@ -0,0 +1,236 @@+{-# LANGUAGE CPP, NoOverloadedLists, NoOverloadedStrings #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}++module Exon.Haskell.Translate (toExp) where++import qualified Data.ByteString as B+import qualified Data.List.NonEmpty as NonEmpty+import GHC.Data.FastString+import GHC.Driver.Ppr (showSDoc)+import GHC.Driver.Session (DynFlags)+import GHC.Hs.Expr as Expr+import GHC.Hs.Extension as Ext+import GHC.Hs.Lit+import GHC.Hs.Pat as Pat+import GHC.Hs.Type (HsSigType (HsSig), HsType (..), HsWildCardBndrs (..), sig_body)+import GHC.Types.Basic (Boxity (..))+import GHC.Types.Name+import GHC.Types.Name.Reader+import GHC.Types.SourceText (il_value, rationalFromFractionalLit)+import GHC.Types.SrcLoc+import qualified GHC.Unit.Module as Module+import GHC.Utils.Outputable (ppr)+import qualified Language.Haskell.TH.Syntax as TH+#if MIN_VERSION_ghc(9,6,0)+import Language.Haskell.Syntax.Basic (FieldLabelString (..))+#endif++import qualified Exon.Haskell.Settings as Settings++-- TODO: why this disapears in GHC >= 9.2?+fl_value = rationalFromFractionalLit++++-----------------------------++toLit :: HsLit GhcPs -> TH.Lit+toLit (HsChar _ c) = TH.CharL c+toLit (HsCharPrim _ c) = TH.CharPrimL c+toLit (HsString _ s) = TH.StringL (unpackFS s)+toLit (HsStringPrim _ s) = TH.StringPrimL (B.unpack s)+toLit (HsInt _ i) = TH.IntegerL (il_value i)+toLit (HsIntPrim _ i) = TH.IntPrimL i+toLit (HsWordPrim _ i) = TH.WordPrimL i+toLit (HsInt64Prim _ i) = TH.IntegerL i+toLit (HsWord64Prim _ i) = TH.WordPrimL i+toLit (HsInteger _ i _) = TH.IntegerL i+toLit (HsRat _ f _) = TH.FloatPrimL (fl_value f)+toLit (HsFloatPrim _ f) = TH.FloatPrimL (fl_value f)+toLit (HsDoublePrim _ f) = TH.DoublePrimL (fl_value f)++toLit' :: OverLitVal -> TH.Lit+toLit' (HsIntegral i) = TH.IntegerL (il_value i)+toLit' (HsFractional f) = TH.RationalL (fl_value f)+toLit' (HsIsString _ fs) = TH.StringL (unpackFS fs)++toType :: HsType GhcPs -> TH.Type+toType (HsWildCardTy _) = TH.WildCardT+toType (HsTyVar _ _ n) =+  let n' = unLoc n+   in if isRdrTyVar n'+        then TH.VarT (toName n')+        else TH.ConT (toName n')+toType t = todo "toType" (showSDoc(Settings.baseDynFlags []) . ppr $ t)++toName :: RdrName -> TH.Name+toName n = case n of+  (Unqual o) -> TH.mkName (occNameString o)+  (Qual m o) -> TH.mkName (Module.moduleNameString m <> "." <> occNameString o)+  (Orig _ _) -> error "orig"+  (Exact _) -> error "exact"++toFieldExp :: a+toFieldExp = undefined++toPat :: DynFlags -> Pat.Pat GhcPs -> TH.Pat+toPat _dynFlags (Pat.VarPat _ (unLoc -> name)) = TH.VarP (toName name)+toPat dynFlags p = todo "toPat" (showSDoc dynFlags . ppr $ p)++toExp :: DynFlags -> Expr.HsExpr GhcPs -> TH.Exp+toExp _ (Expr.HsVar _ n) =+  let n' = unLoc n+   in if isRdrDataCon n'+        then TH.ConE (toName n')+        else TH.VarE (toName n')++toExp _ (Expr.HsUnboundVar _ n)              = TH.UnboundVarE (TH.mkName . occNameString . occName $ n)++toExp _ Expr.HsIPVar {}+  = noTH "toExp" "HsIPVar"++toExp _ (Expr.HsLit _ l)+  = TH.LitE (toLit l)++toExp _ (Expr.HsOverLit _ OverLit {ol_val})+  = TH.LitE (toLit' ol_val)++toExp d (Expr.HsApp _ e1 e2)+  = TH.AppE (toExp d . unLoc $ e1) (toExp d . unLoc $ e2)++#if MIN_VERSION_ghc(9,6,0)+toExp d (Expr.HsAppType _ e _ HsWC {hswc_body}) = TH.AppTypeE (toExp d . unLoc $ e) (toType . unLoc $ hswc_body)+#else+toExp d (Expr.HsAppType _ e HsWC {hswc_body}) = TH.AppTypeE (toExp d . unLoc $ e) (toType . unLoc $ hswc_body)+#endif++toExp d (Expr.ExprWithTySig _ e HsWC{hswc_body=unLoc -> HsSig{sig_body}}) = TH.SigE (toExp d . unLoc $ e) (toType . unLoc $ sig_body)++toExp d (Expr.OpApp _ e1 o e2)+  = TH.UInfixE (toExp d . unLoc $ e1) (toExp d . unLoc $ o) (toExp d . unLoc $ e2)++toExp d (Expr.NegApp _ e _)+  = TH.AppE (TH.VarE 'negate) (toExp d . unLoc $ e)++-- NOTE: for lambda, there is only one match+#if MIN_VERSION_ghc(9,6,0)+toExp d (Expr.HsLam _ (Expr.MG _ (unLoc -> (map unLoc -> [Expr.Match _ _ (map unLoc -> ps) (Expr.GRHSs _ [unLoc -> Expr.GRHS _ _ (unLoc -> e)] _)]))))+#else+toExp d (Expr.HsLam _ (Expr.MG _ (unLoc -> (map unLoc -> [Expr.Match _ _ (map unLoc -> ps) (Expr.GRHSs _ [unLoc -> Expr.GRHS _ _ (unLoc -> e)] _)])) _))+#endif+  = TH.LamE (fmap (toPat d) ps) (toExp d e)++-- toExp (Expr.Let _ bs e)                       = TH.LetE (toDecs bs) (toExp e)+--+toExp d (Expr.HsIf _ a b c)                   = TH.CondE (toExp d (unLoc a)) (toExp d (unLoc b)) (toExp d (unLoc c))++-- toExp (Expr.MultiIf _ ifs)                    = TH.MultiIfE (map toGuard ifs)+-- toExp (Expr.Case _ e alts)                    = TH.CaseE (toExp e) (map toMatch alts)+-- toExp (Expr.Do _ ss)                          = TH.DoE (map toStmt ss)+-- toExp e@Expr.MDo{}                            = noTH "toExp" e+--+toExp d (Expr.ExplicitTuple _ args boxity) = ctor tupArgs+  where+    toTupArg (Expr.Present _ e) = Just $ unLoc e+    toTupArg (Expr.Missing _) = Nothing+    toTupArg _ = error "impossible case"++    ctor = case boxity of+      Boxed -> TH.TupE+      Unboxed -> TH.UnboxedTupE++    tupArgs = fmap ((fmap (toExp d)) . toTupArg) args++-- toExp (Expr.List _ xs)                        = TH.ListE (fmap toExp xs)+#if MIN_VERSION_ghc(9, 4, 0)+toExp d (Expr.HsPar _ _ e _)+#else+toExp d (Expr.HsPar _ e)+#endif+  = TH.ParensE (toExp d . unLoc $ e)++toExp d (Expr.SectionL _ (unLoc -> a) (unLoc -> b))+  = TH.InfixE (Just . toExp d $ a) (toExp d b) Nothing++toExp d (Expr.SectionR _ (unLoc -> a) (unLoc -> b))+  = TH.InfixE Nothing (toExp d a) (Just . toExp d $ b)++toExp _ (Expr.RecordCon _ name HsRecFields {rec_flds})+  = TH.RecConE (toName . unLoc $ name) (fmap toFieldExp rec_flds)++-- toExp (Expr.RecUpdate _ e xs)                 = TH.RecUpdE (toExp e) (fmap toFieldExp xs)+-- toExp (Expr.ListComp _ e ss)                  = TH.CompE $ map convert ss ++ [TH.NoBindS (toExp e)]+--  where+--   convert (Expr.QualStmt _ st)                = toStmt st+--   convert s                                   = noTH "toExp ListComp" s+-- toExp (Expr.ExpTypeSig _ e t)                 = TH.SigE (toExp e) (toType t)+--+toExp d (Expr.ExplicitList _ (map unLoc -> args)) = TH.ListE (map (toExp d) args)++toExp d (Expr.ArithSeq _ _ e)+  = TH.ArithSeqE $ case e of+    (From a) -> TH.FromR (toExp d $ unLoc a)+    (FromThen a b) -> TH.FromThenR (toExp d $ unLoc a) (toExp d $ unLoc b)+    (FromTo a b) -> TH.FromToR (toExp d $ unLoc a) (toExp d $ unLoc b)+    (FromThenTo a b c) -> TH.FromThenToR (toExp d $ unLoc a) (toExp d $ unLoc b) (toExp d $ unLoc c)++#if MIN_VERSION_ghc(9, 6, 0)+toExp _ (Expr.HsProjection _ locatedFields) =+  let+    extractFieldLabel (DotFieldOcc _ locatedStr) = field_label <$> locatedStr+    extractFieldLabel _ = error "Don't know how to handle XHsFieldLabel constructor..."+  in+    TH.ProjectionE (NonEmpty.map (unpackFS . unLoc . extractFieldLabel . unLoc) locatedFields)++toExp d (Expr.HsGetField _ expr locatedField) =+  let+    extractFieldLabel (DotFieldOcc _ locatedStr) = field_label <$> locatedStr+    extractFieldLabel _ = error "Don't know how to handle XHsFieldLabel constructor..."+  in+    TH.GetFieldE (toExp d (unLoc expr)) (unpackFS . unLoc . extractFieldLabel . unLoc $ locatedField)+#elif MIN_VERSION_ghc(9, 4, 0)+toExp _ (Expr.HsProjection _ locatedFields) =+  let+    extractFieldLabel (DotFieldOcc _ locatedStr) = locatedStr+    extractFieldLabel _ = error "Don't know how to handle XHsFieldLabel constructor..."+  in+    TH.ProjectionE (NonEmpty.map (unpackFS . unLoc . extractFieldLabel . unLoc) locatedFields)++toExp d (Expr.HsGetField _ expr locatedField) =+  let+    extractFieldLabel (DotFieldOcc _ locatedStr) = locatedStr+    extractFieldLabel _ = error "Don't know how to handle XHsFieldLabel constructor..."+  in+    TH.GetFieldE (toExp d (unLoc expr)) (unpackFS . unLoc . extractFieldLabel . unLoc $ locatedField)+#else+toExp _ (Expr.HsProjection _ locatedFields) =+  let+    extractFieldLabel (HsFieldLabel _ locatedStr) = locatedStr+    extractFieldLabel _ = error "Don't know how to handle XHsFieldLabel constructor..."+  in+    TH.ProjectionE (NonEmpty.map (unpackFS . unLoc . extractFieldLabel . unLoc) locatedFields)++toExp d (Expr.HsGetField _ expr locatedField) =+  let+    extractFieldLabel (HsFieldLabel _ locatedStr) = locatedStr+    extractFieldLabel _ = error "Don't know how to handle XHsFieldLabel constructor..."+  in+    TH.GetFieldE (toExp d (unLoc expr)) (unpackFS . unLoc . extractFieldLabel . unLoc $ locatedField)+#endif++#if MIN_VERSION_ghc(9, 6, 0)+toExp _ (Expr.HsOverLabel _ _ fastString) = TH.LabelE (unpackFS fastString)+#else+toExp _ (Expr.HsOverLabel _ fastString) = TH.LabelE (unpackFS fastString)+#endif++toExp dynFlags e = todo "toExp" (showSDoc dynFlags . ppr $ e)++todo :: (HasCallStack, Show e) => String -> e -> a+todo fun thing = error . concat $ [moduleName, ".", fun, ": not implemented: ", show thing]++noTH :: (HasCallStack, Show e) => String -> e -> a+noTH fun thing = error . concat $ [moduleName, ".", fun, ": no TemplateHaskell for: ", show thing]++moduleName :: String+moduleName = "Language.Haskell.Meta.Translate"

@@ -1,39 +1,32 @@ {-# options_haddock prune #-} --- |Description: The parser for the quasiquote body, using "FlatParse".+-- | Description: The parser for the quasiquote body, using parsec. module Exon.Parse where  import Data.Char (isSpace)-import qualified FlatParse.Stateful as FlatParse-import FlatParse.Stateful (-  Result (Err, Fail, OK),+import Prelude hiding ((<|>))+import Text.Parsec as Parsec (+  Parsec,   anyChar,-  branch,   char,-  empty,-  eof,-  get,-  inSpan,-  lookahead,-  modify,-  put,-  runParserUtf8,+  choice,+  getState,+  lookAhead,+  many1,+  modifyState,+  notFollowedBy,+  option,+  putState,+  runParser,   satisfy,   string,-  takeRestString,-  withSpan,+  try,   (<|>),   )-import Prelude hiding (empty, span, (<|>))  import Exon.Data.RawSegment (RawSegment (AutoExpSegment, ExpSegment, StringSegment, WsSegment)) -type Parser =-  FlatParse.Parser Int Text--span :: Parser () -> Parser String-span seek =-  withSpan seek \ _ sp -> inSpan sp takeRestString+type Parser = Parsec String Int  ws :: Parser Char ws =@@ -41,82 +34,95 @@  whitespace :: Parser RawSegment whitespace =-  WsSegment <$> span (void (some ws))--before ::-  Parser a ->-  Parser () ->-  Parser () ->-  Parser ()-before =-  branch . lookahead+  WsSegment <$> some ws -finishBefore ::-  Parser a ->-  Parser () ->-  Parser ()-finishBefore cond =-  before cond unit+takeRestUnless :: Parser Char -> Parser String+takeRestUnless end =+  many1 (notFollowedBy end *> anyChar) -expr :: Parser ()+expr :: Parser String expr =-  branch $(char '{') (modify (1 +) *> expr) $-  before $(char '}') closing (anyChar *> expr)+  choice [try opening, try closing, anyChars]   where-    closing =-      get >>= \case-        0 -> unit-        cur -> put (cur - 1) *> $(char '}') *> expr+    opening = do+      char '{'+      modifyState (1 +)+      e <- expr+      pure ('{' : e) +    closing = do+      void $ lookAhead (char '}')+      getState >>= \case+        0 -> pure ""+        cur -> do+          putState (cur - 1)+          char '}'+          e <- expr+          pure ('}' : e)++    anyChars = do+      c <- anyChar+      e <- expr+      pure (c : e)+ autoInterpolation :: Parser RawSegment autoInterpolation =-  $(string "##{") *> (AutoExpSegment <$> span expr) <* $(char '}')+  string "##{" *> (AutoExpSegment <$> expr) <* char '}'  verbatimInterpolation :: Parser RawSegment verbatimInterpolation =-  $(string "#{") *> (ExpSegment <$> span expr) <* $(char '}')+  string "#{" *> (ExpSegment <$> expr) <* char '}' -untilTokenEnd :: Parser ()-untilTokenEnd =-  finishBefore ($(string "##{") <|> $(string "#{")) $-  eof <|> (anyChar *> untilTokenEnd)+interpolations :: Parser RawSegment+interpolations =+  try autoInterpolation <|> try verbatimInterpolation -untilTokenEndWs :: Parser ()-untilTokenEndWs =-  finishBefore ($(string "##{") <|> $(string "#{") <|> void ws) $-  eof <|> (anyChar *> untilTokenEndWs)+stopHerald :: Parser String+stopHerald =+  "" <$ lookAhead (try (string "##{") <|> try (string "#{")) +hash :: Parser Char+hash = char '#'++verbatimWith :: Parser Char -> Parser String+verbatimWith end =+  takeRestUnless end <> (stopHerald <|> option "" (try (string "#" <> verbatim)))++verbatim :: Parser String+verbatim =+  verbatimWith hash++verbatimWs :: Parser String+verbatimWs =+  verbatimWith (ws <|> hash)+ text :: Parser RawSegment text =-  StringSegment <$> span untilTokenEnd+  StringSegment <$> verbatim  textWs :: Parser RawSegment textWs =-  StringSegment <$> span untilTokenEndWs+  StringSegment <$> verbatimWs  segment :: Parser RawSegment segment =-  branch eof empty (autoInterpolation <|> verbatimInterpolation <|> text)+  interpolations <|> text  segmentWs :: Parser RawSegment segmentWs =-  branch eof empty (whitespace <|> autoInterpolation <|> verbatimInterpolation <|> textWs)+  try whitespace <|> interpolations <|> textWs  parser :: Parser [RawSegment] parser =-  FlatParse.many segment+  many segment  parserWs :: Parser [RawSegment] parserWs =-  FlatParse.many segmentWs+  many segmentWs  parseWith :: Parser [RawSegment] -> String -> Either Text [RawSegment] parseWith p =-  runParserUtf8 p 0 0 >>> \case-    OK a _ "" -> Right a-    OK _ _ u -> Left ("unconsumed: " <> decodeUtf8 u)-    Fail -> Left "fail"-    Err e -> Left e+  first show . runParser p 0 ""  parse :: String -> Either Text [RawSegment] parse =

@@ -1,9 +1,8 @@ {-# options_haddock prune #-} --- |Description: Internal+-- | Description: Internal module Exon.Quote where -import Language.Haskell.Meta.Parse (parseExpWithExts) import qualified Language.Haskell.TH as TH import Language.Haskell.TH (Exp (AppE, InfixE, ListE), Q, extsEnabled, runQ) import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter))@@ -13,6 +12,7 @@ import Exon.Class.ToSegment (toSegment) import Exon.Data.RawSegment (RawSegment (AutoExpSegment, ExpSegment, StringSegment, WsSegment)) import qualified Exon.Data.Segment as Segment+import Exon.Haskell.Parse (parseExpWithExts) import Exon.Parse (parse, parseWs)  exonError ::@@ -116,7 +116,7 @@   consE <- runQ [e|(:|)|]   pure (InfixE (Just hseg) consE (Just (ListE segs))) --- |Constructor for a quasiquoter that wraps all segments with the first expression and unwraps the result with the+-- | Constructor for a quasiquoter that wraps all segments with the first expression and unwraps the result with the -- second. -- -- This can be used to define quoters with custom logic by providing instances of any of the classes in@@ -145,7 +145,7 @@     err tpe _ =       exonError ("Cannot quote " <> tpe) --- |A quasiquoter that allows interpolation, concatenating the resulting segments with '(<>)' or a an arbitrary+-- | A quasiquoter that allows interpolation, concatenating the resulting segments with '(<>)' or a an arbitrary -- user-defined implementation. -- See the [introduction]("Exon") for details. --@@ -155,14 +155,14 @@ exon =   exonWith Nothing False False --- |Unsafe version of 'exon', allowing automatic conversion with the same splice brackets as matching types.+-- | Unsafe version of 'exon', allowing automatic conversion with the same splice brackets as matching types. -- -- @since 1.0.0.0 exun :: QuasiQuoter exun =   exonWith Nothing False True --- |A variant of 'exon' that creates segments for each sequence of whitespace characters that can be processed+-- | A variant of 'exon' that creates segments for each sequence of whitespace characters that can be processed -- differently by 'Exon.ExonAppend', 'Exon.ExonSegment' or 'Exon.ExonString'. -- -- @since 1.0.0.0@@ -170,7 +170,7 @@ exonws =   exonWith Nothing True False --- |Internal debugging quoter that produces the raw segments.+-- | Internal debugging quoter that produces the raw segments. -- -- @since 1.0.0.0 exonSegments :: QuasiQuoter

@@ -1,4 +1,4 @@--- |Whitespace skipping quoter, internal+-- | Whitespace skipping quoter, internal module Exon.SkipWs where  import Language.Haskell.TH.Quote (QuasiQuoter)@@ -7,7 +7,7 @@ import Exon.Data.Result (Result (Empty)) import Exon.Quote (exonWith) --- |Wrapping a quote type with this causes whitespace to be ignored.+-- | Wrapping a quote type with this causes whitespace to be ignored. -- -- @since 1.0.0.0 newtype SkipWs a =@@ -15,14 +15,14 @@   deriving stock (Eq, Show, Generic)   deriving newtype (IsString) --- |Defined separately because TH chokes on the selector.+-- | Defined separately because TH chokes on the selector. -- -- @since 1.0.0.0 skipWs :: SkipWs a -> a skipWs (SkipWs a) =   a --- |The instance used when the result type is wrapped in 'SkipWs', which is done by 'Exon.intron'.+-- | The instance used when the result type is wrapped in 'SkipWs', which is done by 'Exon.intron'. -- -- It returns 'Empty' for any whitespace. instance (@@ -32,7 +32,7 @@     Empty   {-# inline exonWhitespace #-} --- |A variant of 'Exon.exon' that ignores all literal whitespace in the quote (not in interpolated expressions).+-- | A variant of 'Exon.exon' that ignores all literal whitespace in the quote (not in interpolated expressions). -- -- > [intron|x|] === skipWs [exonws|x|] --

@@ -10,6 +10,10 @@   Nt Text   deriving stock (Eq, Show, Generic) +newtype NtR =+  NtR { field :: Text }+  deriving stock (Eq, Show, Generic)+ newtype Str =   Str Text   deriving stock (Eq, Show)@@ -39,12 +43,15 @@     StrUse (StrGen "")  nt :: Nt-nt =-  Nt "nt"+nt = Nt "nt" +ntr :: NtR+ntr = NtR "ntr"+ test_newtype :: TestT IO () test_newtype = do   ("pre nt Text" :: Text) === [exon|pre ##{nt} #{"Text" :: Text}|]+  ("pre ntr Text" :: Text) === [exon|pre ##{ntr} #{"Text" :: Text}|]   ("pre nt Nt \"nt\"" :: Text) === [exon|pre ##{nt} #{show nt}|]   ("pre nt Nt \"nt\" IsString" :: Text) === [exon|pre ##{nt} #{show nt} #{"IsString"}|]   ("pre nt Nt \"nt\" IsString Text" :: Text) === [exon|pre ##{nt} #{show nt} #{"IsString"} #{"Text" :: Text}|]