exon 1.4.0.0 → 1.7.3.0
raw patch · 21 files changed
Files
- changelog.md +9/−0
- exon.cabal +43/−118
- lib/Exon.hs +2/−2
- lib/Exon/Class/Exon.hs +25/−22
- lib/Exon/Class/Newtype.hs +5/−7
- lib/Exon/Class/ToSegment.hs +6/−12
- lib/Exon/Combinators.hs +34/−10
- 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 +89/−0
- lib/Exon/Haskell/Translate.hs +265/−0
- lib/Exon/Parse.hs +81/−65
- lib/Exon/Quote.hs +8/−7
- lib/Exon/SkipWs.hs +5/−5
- test/Exon/Test/BasicTest.hs +6/−1
- test/Exon/Test/NewtypeTest.hs +10/−2
- test/Exon/Test/ParseTest.hs +9/−0
- test/Main.hs +3/−1
changelog.md view
@@ -1,3 +1,12 @@+# 1.6.0.0++* Replace `flatparse` with `parsec` for less friction when updating GHC.++# 1.5.0.0++* Use `exonProcess` for `intercalate`+* Add `intercalate1` for `NonEmpty`+ # 1.2.0.0 * Add class `ExonExpression`, allowing customization of how interpolated expressions are converted to builders.
exon.cabal view
@@ -1,29 +1,29 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.35.0.+-- This file has been generated from package.yaml by hpack version 0.38.3. -- -- see: https://github.com/sol/hpack name: exon-version: 1.4.0.0-synopsis: Customizable Quasiquote Interpolation+version: 1.7.3.0+synopsis: Customizable quasiquote interpolation description: See https://hackage.haskell.org/package/exon/docs/Exon.html category: String-homepage: https://git.tryp.io/tek/exon+homepage: https://github.com/tek/exon#readme bug-reports: https://github.com/tek/exon/issues author: Torsten Schmits maintainer: hackage@tryp.io-copyright: 2022 Torsten Schmits+copyright: 2025 Torsten Schmits license: BSD-2-Clause-Patent license-file: LICENSE build-type: Simple extra-source-files:- changelog.md readme.md+ changelog.md source-repository head type: git- location: https://git.tryp.io/tek/exon+ location: https://github.com/tek/exon library exposed-modules:@@ -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@@ -44,86 +47,60 @@ default-extensions: AllowAmbiguousTypes ApplicativeDo- BangPatterns- BinaryLiterals BlockArguments- ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass- DeriveDataTypeable- DeriveFoldable- DeriveFunctor- DeriveGeneric- DeriveLift- DeriveTraversable DerivingStrategies DerivingVia DisambiguateRecordFields- DoAndIfThenElse DuplicateRecordFields- EmptyCase- EmptyDataDecls- ExistentialQuantification- FlexibleContexts- FlexibleInstances FunctionalDependencies GADTs- GeneralizedNewtypeDeriving- InstanceSigs- KindSignatures LambdaCase LiberalTypeSynonyms- MultiParamTypeClasses+ MonadComprehensions MultiWayIf- NamedFieldPuns+ NoFieldSelectors OverloadedLabels OverloadedLists+ OverloadedRecordDot OverloadedStrings PackageImports PartialTypeSignatures- PatternGuards PatternSynonyms- PolyKinds QuantifiedConstraints QuasiQuotes- RankNTypes RecordWildCards RecursiveDo RoleAnnotations- ScopedTypeVariables- StandaloneDeriving TemplateHaskell- TupleSections- TypeApplications TypeFamilies TypeFamilyDependencies- TypeOperators- TypeSynonymInstances UndecidableInstances UnicodeSyntax ViewPatterns- ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages+ ghc-options: -Wall -Widentities -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wredundant-constraints -Wunused-type-patterns -Wunused-packages build-depends:- base >=4.12 && <5- , flatparse ==0.4.*- , generics-sop >=0.5.1.1 && <0.6- , ghc-hs-meta ==0.1.*- , incipit-base ==0.5.*- , template-haskell+ base >=4.17.2.1 && <4.23+ , ghc >=9.4.8 && <9.15+ , incipit-base >=0.5.0.0 && <0.8+ , parsec >=3.1.15.1 && <3.2+ , template-haskell >=2.19.0.0 && <2.25 mixins: base hiding (Prelude) , incipit-base (IncipitBase as Prelude) , incipit-base hiding (IncipitBase)- default-language: Haskell2010+ default-language: GHC2021 -test-suite exon-unit+test-suite exon-test type: exitcode-stdio-1.0 main-is: Main.hs other-modules: Exon.Test.BasicTest Exon.Test.BuildTest Exon.Test.NewtypeTest+ Exon.Test.ParseTest Exon.Test.Quote Exon.Test.ShowsPrecTest Exon.Test.SkipWsTest@@ -132,79 +109,53 @@ default-extensions: AllowAmbiguousTypes ApplicativeDo- BangPatterns- BinaryLiterals BlockArguments- ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass- DeriveDataTypeable- DeriveFoldable- DeriveFunctor- DeriveGeneric- DeriveLift- DeriveTraversable DerivingStrategies DerivingVia DisambiguateRecordFields- DoAndIfThenElse DuplicateRecordFields- EmptyCase- EmptyDataDecls- ExistentialQuantification- FlexibleContexts- FlexibleInstances FunctionalDependencies GADTs- GeneralizedNewtypeDeriving- InstanceSigs- KindSignatures LambdaCase LiberalTypeSynonyms- MultiParamTypeClasses+ MonadComprehensions MultiWayIf- NamedFieldPuns+ NoFieldSelectors OverloadedLabels OverloadedLists+ OverloadedRecordDot OverloadedStrings PackageImports PartialTypeSignatures- PatternGuards PatternSynonyms- PolyKinds QuantifiedConstraints QuasiQuotes- RankNTypes RecordWildCards RecursiveDo RoleAnnotations- ScopedTypeVariables- StandaloneDeriving TemplateHaskell- TupleSections- TypeApplications TypeFamilies TypeFamilyDependencies- TypeOperators- TypeSynonymInstances UndecidableInstances UnicodeSyntax ViewPatterns- ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages -threaded -rtsopts -with-rtsopts=-N+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Widentities -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wredundant-constraints -Wunused-type-patterns -Wunused-packages build-depends:- base >=4.12 && <5- , exon- , hedgehog- , incipit-base ==0.5.*- , tasty- , tasty-hedgehog- , template-haskell+ base >=4.17.2.1 && <4.23+ , exon <1.8+ , hedgehog >=1.1.2 && <1.8+ , incipit-base >=0.5.0.0 && <0.8+ , tasty >=1.2.2 && <1.6+ , tasty-hedgehog >=1.3.0.0 && <1.5+ , template-haskell >=2.19.0.0 && <2.25 mixins: base hiding (Prelude) , incipit-base (IncipitBase as Prelude) , incipit-base hiding (IncipitBase)- default-language: Haskell2010+ default-language: GHC2021 benchmark exon-bench type: exitcode-stdio-1.0@@ -214,73 +165,47 @@ default-extensions: AllowAmbiguousTypes ApplicativeDo- BangPatterns- BinaryLiterals BlockArguments- ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass- DeriveDataTypeable- DeriveFoldable- DeriveFunctor- DeriveGeneric- DeriveLift- DeriveTraversable DerivingStrategies DerivingVia DisambiguateRecordFields- DoAndIfThenElse DuplicateRecordFields- EmptyCase- EmptyDataDecls- ExistentialQuantification- FlexibleContexts- FlexibleInstances FunctionalDependencies GADTs- GeneralizedNewtypeDeriving- InstanceSigs- KindSignatures LambdaCase LiberalTypeSynonyms- MultiParamTypeClasses+ MonadComprehensions MultiWayIf- NamedFieldPuns+ NoFieldSelectors OverloadedLabels OverloadedLists+ OverloadedRecordDot OverloadedStrings PackageImports PartialTypeSignatures- PatternGuards PatternSynonyms- PolyKinds QuantifiedConstraints QuasiQuotes- RankNTypes RecordWildCards RecursiveDo RoleAnnotations- ScopedTypeVariables- StandaloneDeriving TemplateHaskell- TupleSections- TypeApplications TypeFamilies TypeFamilyDependencies- TypeOperators- TypeSynonymInstances UndecidableInstances UnicodeSyntax ViewPatterns- ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages+ ghc-options: -Wall -Widentities -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wredundant-constraints -Wunused-type-patterns -Wunused-packages build-depends:- base >=4.12 && <5- , criterion- , exon- , incipit-base ==0.5.*+ base >=4.17.2.1 && <4.23+ , criterion >=1.5.13.0 && <1.7+ , exon <1.8+ , incipit-base >=0.5.0.0 && <0.8 mixins: base hiding (Prelude) , incipit-base (IncipitBase as Prelude) , incipit-base hiding (IncipitBase)- default-language: Haskell2010+ default-language: GHC2021
lib/Exon.hs view
@@ -1,4 +1,4 @@--- |Customizable Quasiquote Interpolation+-- | Customizable Quasiquote Interpolation module Exon ( -- * Introduction -- $intro@@ -52,7 +52,7 @@ ExonUse (..), ) import Exon.Class.ToSegment (ToSegment (..))-import Exon.Combinators (intercalate)+import Exon.Combinators (intercalate, intercalate1, intercalateMay) import Exon.Data.Result (Result (..)) import Exon.Data.Segment (Segment (..)) import Exon.Quote (exon, exonWith, exonws, exun)
lib/Exon/Class/Exon.hs view
@@ -1,4 +1,4 @@--- |Description: Internal+-- | Description: Internal module Exon.Class.Exon where import qualified Data.ByteString.Builder as ByteString@@ -11,22 +11,25 @@ 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 =- ExonUse { exonUse :: a }+ ExonUse a deriving stock (Eq, Show) deriving newtype (IsString) --- |This class converts a segment into a builder.+exonUse :: ExonUse a -> a+exonUse = coerce++-- | 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@@ -34,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 ::@@ -91,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'.@@ -101,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@@ -109,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 @@ -120,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@@ -139,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: --@@ -155,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 #-} (@@ -171,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@@ -186,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. --@@ -213,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.@@ -224,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 #-} (@@ -238,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@@ -257,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 ::
lib/Exon/Class/Newtype.hs view
@@ -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 #-}
lib/Exon/Class/ToSegment.hs view
@@ -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
lib/Exon/Combinators.hs view
@@ -1,19 +1,43 @@--- |Description: Internal+-- | Description: Internal module Exon.Combinators where -import Prelude hiding (intercalate)+import qualified Data.List.NonEmpty as NonEmpty+import Prelude hiding (intersperse) --- |Monoidally combine all elements in the list, appending the separator between each pair of elements.+import Exon.Class.Exon (Exon (exonProcess))+import qualified Exon.Data.Segment as Segment++-- | Combine the elements in the list using 'Exon', interspersing the separator between each pair of elements.+intercalate1 ::+ Exon a =>+ a ->+ NonEmpty a ->+ a+intercalate1 sep ta =+ exonProcess (Segment.Expression <$> NonEmpty.intersperse sep ta)++-- | Combine the elements in the list using 'Exon', interspersing the separator between each pair of elements.+--+-- Returns 'Nothing' when the list is empty.+intercalateMay ::+ Exon a =>+ Foldable t =>+ a ->+ t a ->+ Maybe a+intercalateMay sep ta =+ intercalate1 sep <$> nonEmpty (toList ta)++-- | Combine the elements in the list using 'Exon', interspersing the separator between each pair of elements.+--+-- Returns 'mempty' for empty lists; use 'intercalate1' for 'NonEmpty' or 'intercalateMay' to avoid the 'Monoid'+-- requirement. intercalate ::+ Exon a => Monoid a => Foldable t => a -> t a -> a-intercalate sep =- fold . foldl' f Nothing- where- f Nothing a =- Just a- f (Just z) a =- Just (z <> sep <> a)+intercalate sep ta =+ fromMaybe mempty (intercalateMay sep ta)
lib/Exon/Data/RawSegment.hs view
@@ -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 |
lib/Exon/Data/Result.hs view
@@ -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 |
lib/Exon/Data/Segment.hs view
@@ -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
lib/Exon/Generic.hs view
@@ -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)
+ lib/Exon/Haskell/Parse.hs view
@@ -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
+ lib/Exon/Haskell/Settings.hs view
@@ -0,0 +1,89 @@+{-# 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.Unit.Types+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+#if MIN_VERSION_ghc(9,14,0)+ , sUnitSettings=UnitSettings {unitSettings_baseUnitId = stringToUnitId "base"}+#endif+ }+ 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
+ lib/Exon/Haskell/Translate.hs view
@@ -0,0 +1,265 @@+{-# 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++import qualified Exon.Haskell.Settings as Settings++#if MIN_VERSION_ghc(9,6,0)+import Language.Haskell.Syntax.Basic (FieldLabelString (..))+#endif++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+#if MIN_VERSION_ghc(9,14,0)+toLit (HsMultilineString _ s) = TH.StringL (unpackFS s)+#else+toLit (HsRat _ f _) = TH.FloatPrimL (fl_value f)+#endif+toLit (HsFloatPrim _ f) = TH.FloatPrimL (fl_value f)+toLit (HsDoublePrim _ f) = TH.DoublePrimL (fl_value f)+#if MIN_VERSION_ghc(9,8,0)+toLit (HsInt8Prim _ i) = TH.IntegerL i+toLit (HsInt16Prim _ i) = TH.IntegerL i+toLit (HsInt32Prim _ i) = TH.IntegerL i+toLit (HsWord8Prim _ i) = TH.WordPrimL i+toLit (HsWord16Prim _ i) = TH.WordPrimL i+toLit (HsWord32Prim _ i) = TH.WordPrimL i+#endif++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')++#if !MIN_VERSION_ghc(9,14,0)+toExp _ (Expr.HsUnboundVar _ n) = TH.UnboundVarE (TH.mkName . occNameString . occName $ n)+#endif++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,10,0)+toExp d (Expr.HsAppType _ e HsWC {hswc_body}) = TH.AppTypeE (toExp d . unLoc $ e) (toType . unLoc $ hswc_body)+#elif 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,14,0)+toExp d (Expr.HsLam _ _ (Expr.MG _ (unLoc -> (map unLoc -> [Expr.Match _ _ (map unLoc . unLoc -> ps) (Expr.GRHSs _ ((unLoc -> Expr.GRHS _ _ (unLoc -> e)) :| []) _)]))))+#elif MIN_VERSION_ghc(9,12,0)+toExp d (Expr.HsLam _ _ (Expr.MG _ (unLoc -> (map unLoc -> [Expr.Match _ _ (map unLoc . unLoc -> ps) (Expr.GRHSs _ [unLoc -> Expr.GRHS _ _ (unLoc -> e)] _)]))))+#elif MIN_VERSION_ghc(9,10,0)+toExp d (Expr.HsLam _ _ (Expr.MG _ (unLoc -> (map unLoc -> [Expr.Match _ _ (map unLoc -> ps) (Expr.GRHSs _ [unLoc -> Expr.GRHS _ _ (unLoc -> e)] _)]))))+#elif 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,10,0)+toExp d (Expr.HsPar _ e)+#elif 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+#if MIN_VERSION_ghc(9, 12, 0)+ TH.ProjectionE (NonEmpty.map (unpackFS . unLoc . extractFieldLabel) locatedFields)+#else+ TH.ProjectionE (NonEmpty.map (unpackFS . unLoc . extractFieldLabel . unLoc) locatedFields)+#endif++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, 12, 0)+toExp _ (Expr.HsOverLabel _ fastString) = TH.LabelE (unpackFS fastString)+#elif 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"
lib/Exon/Parse.hs view
@@ -1,39 +1,30 @@ {-# 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,+ choice, eof,- get,- inSpan,- lookahead,- modify,- put,- runParserUtf8,+ getState,+ lookAhead,+ modifyState,+ 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 +32,107 @@ whitespace :: Parser RawSegment whitespace =- WsSegment <$> span (void (some ws))--before ::- Parser a ->- Parser () ->- Parser () ->- Parser ()-before =- branch . lookahead--finishBefore ::- Parser a ->- Parser () ->- Parser ()-finishBefore cond =- before cond unit+ WsSegment <$> some ws -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)+verbatimStep :: Bool -> Parser Bool+verbatimStep =+ lookAhead . \case+ True -> False <$ ws <|> basic+ False -> basic+ where+ basic =+ False <$ (try (string "##{") <|> try (string "#{"))+ <|>+ False <$ eof+ <|>+ pure True +verbatimWith :: Parser Bool -> Parser String+verbatimWith step =+ step >>= \case+ False -> fail "Empty verbatim segment"+ True -> go+ where+ go =+ step >>= \case+ False -> pure ""+ True -> do+ h <- anyChar+ t <- go+ pure (h : t)++verbatim :: Parser String+verbatim =+ verbatimWith (verbatimStep False)++verbatimWs :: Parser String+verbatimWs =+ verbatimWith (verbatimStep True)+ 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 <* eof parserWs :: Parser [RawSegment] parserWs =- FlatParse.many segmentWs+ many segmentWs <* eof 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 (unwords . lines . show) . runParser p 0 "" parse :: String -> Either Text [RawSegment] parse =
lib/Exon/Quote.hs view
@@ -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 ::@@ -51,6 +51,7 @@ QOrIO m => String -> m Exp+reifyExp "" = exonError ("Empty interpolation" :: String) reifyExp s = do exts <- fileExtensions case parseExpWithExts exts s of@@ -116,7 +117,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 +146,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 +156,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 +171,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
lib/Exon/SkipWs.hs view
@@ -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|] --
test/Exon/Test/BasicTest.hs view
@@ -45,12 +45,17 @@ "Philip | J. | FRY" === skipWs [exonws|Philip J. #{SkipWs (up lastName)}|] "Philip J. | FRY" === [exon|Philip J.#{up lastName}|] ("abc" :: Text) === skipWs [exonws|a ##{"b" :: Text} #{"c"}|]+ ("one #" :: Text) === [exon|one #|]+ ("one ##bug} two three" :: Text) === [exon|one ##bug} two #{"three"}|] where var :: IsString a => a var = "and" -newtype Thing = Thing String deriving stock (Generic) deriving newtype (IsString, Show, Eq)+newtype Thing =+ Thing String+ deriving stock (Generic)+ deriving newtype (IsString, Show, Eq) instance ExonSegment Thing inner String where exonSegment builder = \case
test/Exon/Test/NewtypeTest.hs view
@@ -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}|]@@ -56,3 +63,4 @@ ("pre|post" :: StrUse) === exonUse (skipWs [exonws|pre ##{"post" :: Text}|]) ("prepost" :: StrUse) === skipWs [exonws|pre ##{"post" :: Text}|] ("pre post" :: Str) === [exon|pre ##{StrUse "post"}|]+ ("one #two" :: Text) === [exon|one ###{Nt "two"}|]
+ test/Exon/Test/ParseTest.hs view
@@ -0,0 +1,9 @@+module Exon.Test.ParseTest where++import Hedgehog (TestT, assert)+import Exon.Parse (parse)++test_parser :: TestT IO ()+test_parser = do+ assert (isLeft (parse "pre #{incomplete"))+ assert (isLeft (parse "pre ##{incomplete"))
test/Main.hs view
@@ -3,6 +3,7 @@ import Exon.Test.BasicTest (test_basic, test_customWhitespace) import Exon.Test.BuildTest (test_build) import Exon.Test.NewtypeTest (test_newtype)+import Exon.Test.ParseTest (test_parser) import Exon.Test.ShowsPrecTest (test_showsPrec) import Exon.Test.SkipWsTest (test_skipWs) import Hedgehog (TestT, property, test, withTests)@@ -24,7 +25,8 @@ unitTest "custom whitespace handling" test_customWhitespace, unitTest "concat showsPrec fragments" test_showsPrec, unitTest "skip whitespace quoter" test_skipWs,- unitTest "segment newtype conversion" test_newtype+ unitTest "segment newtype conversion" test_newtype,+ unitTest "parser" test_parser ] main :: IO ()