{-# LANGUAGE DeriveAnyClass, DeriveGeneric, LambdaCase, TemplateHaskell, TypeApplications #-}

module TreeSitter.GenerateSyntax
( syntaxDatatype
, astDeclarationsForLanguage
) where

import Language.Haskell.TH as TH
import Language.Haskell.TH.Syntax as TH
import TreeSitter.Deserialize (Datatype (..), DatatypeName (..), Field (..), Children(..), Required (..), Type (..), Named (..), Multiple (..))
import Data.List.NonEmpty (NonEmpty (..))
import Data.List
import Data.Foldable
import Data.Text (Text)
import qualified TreeSitter.Unmarshal as TS
import GHC.Generics hiding (Constructor, Datatype)
import Foreign.Ptr
import qualified TreeSitter.Language as TS
import Foreign.C.String
import Data.Aeson hiding (String)
import System.Directory
import System.FilePath.Posix
import TreeSitter.Node
import TreeSitter.Token
import TreeSitter.Symbol (TSSymbol, toHaskellCamelCaseIdentifier, toHaskellPascalCaseIdentifier)

-- | Derive Haskell datatypes from a language and its @node-types.json@ file.
--
-- Datatypes will be generated according to the specification in the @node-types.json@ file, with anonymous leaf types defined as synonyms for the 'Token' datatype.
--
-- Any datatypes among the node types which have already been defined in the module where the splice is run will be skipped, allowing customization of the representation of parts of the tree. Note that this should be used sparingly, as it imposes extra maintenance burden, particularly when the grammar is changed. This may be used to e.g. parse literals into Haskell equivalents (e.g. parsing the textual contents of integer literals into 'Integer's), and may require defining 'TS.UnmarshalAnn' or 'TS.SymbolMatching' instances for (parts of) the custom datatypes, depending on where and how the datatype occurs in the generated tree, in addition to the usual 'Foldable', 'Functor', etc. instances provided for generated datatypes.
astDeclarationsForLanguage :: Ptr TS.Language -> FilePath -> Q [Dec]
astDeclarationsForLanguage :: Ptr Language -> FilePath -> Q [Dec]
astDeclarationsForLanguage language :: Ptr Language
language filePath :: FilePath
filePath = do
  [Dec]
_ <- FilePath -> Q [Dec]
TS.addDependentFileRelative FilePath
filePath
  FilePath
currentFilename <- Loc -> FilePath
loc_filename (Loc -> FilePath) -> Q Loc -> Q FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Loc
location
  FilePath
pwd             <- IO FilePath -> Q FilePath
forall a. IO a -> Q a
runIO IO FilePath
getCurrentDirectory
  let invocationRelativePath :: FilePath
invocationRelativePath = FilePath -> FilePath
takeDirectory (FilePath
pwd FilePath -> FilePath -> FilePath
</> FilePath
currentFilename) FilePath -> FilePath -> FilePath
</> FilePath
filePath
  [Datatype]
input <- IO (Either FilePath [Datatype]) -> Q (Either FilePath [Datatype])
forall a. IO a -> Q a
runIO (FilePath -> IO (Either FilePath [Datatype])
forall a. FromJSON a => FilePath -> IO (Either FilePath a)
eitherDecodeFileStrict' FilePath
invocationRelativePath) Q (Either FilePath [Datatype])
-> (Either FilePath [Datatype] -> Q [Datatype]) -> Q [Datatype]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath -> Q [Datatype])
-> ([Datatype] -> Q [Datatype])
-> Either FilePath [Datatype]
-> Q [Datatype]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> Q [Datatype]
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail [Datatype] -> Q [Datatype]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  [(FilePath, Named)]
allSymbols <- IO [(FilePath, Named)] -> Q [(FilePath, Named)]
forall a. IO a -> Q a
runIO (Ptr Language -> IO [(FilePath, Named)]
getAllSymbols Ptr Language
language)
  [Dec]
debugSymbolNames <- [d|
    debugSymbolNames :: [String]
    debugSymbolNames = $(listE (map (litE . stringL . debugPrefix) allSymbols))
    |]
  ([Dec]
debugSymbolNames [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<>) ([Dec] -> [Dec]) -> ([[Dec]] -> [Dec]) -> [[Dec]] -> [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Foldable [] => [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat @[] ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Datatype -> Q [Dec]) -> [Datatype] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Ptr Language -> [(FilePath, Named)] -> Datatype -> Q [Dec]
syntaxDatatype Ptr Language
language [(FilePath, Named)]
allSymbols) [Datatype]
input

-- Build a list of all symbols
getAllSymbols :: Ptr TS.Language -> IO [(String, Named)]
getAllSymbols :: Ptr Language -> IO [(FilePath, Named)]
getAllSymbols language :: Ptr Language
language = do
  Word32
count <- Ptr Language -> IO Word32
TS.ts_language_symbol_count Ptr Language
language
  (TSSymbol -> IO (FilePath, Named))
-> [TSSymbol] -> IO [(FilePath, Named)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TSSymbol -> IO (FilePath, Named)
getSymbol [(0 :: TSSymbol) .. Word32 -> TSSymbol
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word32
forall a. Enum a => a -> a
pred Word32
count)]
  where
    getSymbol :: TSSymbol -> IO (FilePath, Named)
getSymbol i :: TSSymbol
i = do
      CString
cname <- Ptr Language -> TSSymbol -> IO CString
TS.ts_language_symbol_name Ptr Language
language TSSymbol
i
      FilePath
n <- CString -> IO FilePath
peekCString CString
cname
      Int
t <- Ptr Language -> TSSymbol -> IO Int
TS.ts_language_symbol_type Ptr Language
language TSSymbol
i
      let named :: Named
named = if Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then Named
Named else Named
Anonymous
      (FilePath, Named) -> IO (FilePath, Named)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
n, Named
named)

-- Auto-generate Haskell datatypes for sums, products and leaf types
syntaxDatatype :: Ptr TS.Language -> [(String, Named)] -> Datatype -> Q [Dec]
syntaxDatatype :: Ptr Language -> [(FilePath, Named)] -> Datatype -> Q [Dec]
syntaxDatatype language :: Ptr Language
language allSymbols :: [(FilePath, Named)]
allSymbols datatype :: Datatype
datatype = Q [Dec] -> Q [Dec]
forall a. Q [a] -> Q [a]
skipDefined (Q [Dec] -> Q [Dec]) -> Q [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ do
  Name
typeParameterName <- FilePath -> Q Name
newName "a"
  case Datatype
datatype of
    SumType (DatatypeName _) _ subtypes :: NonEmpty Type
subtypes -> do
      Type
types' <- NonEmpty Type -> Q Type
fieldTypesToNestedSum NonEmpty Type
subtypes
      Con
con <- Name -> [BangTypeQ] -> ConQ
normalC Name
name [BangQ -> Q Type -> BangTypeQ
TH.bangType BangQ
strictness (Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
types' Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
typeParameterName)]
      [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Cxt
-> Name -> [TyVarBndr] -> Maybe Type -> Con -> [DerivClause] -> Dec
NewtypeD [] Name
name [Name -> TyVarBndr
PlainTV Name
typeParameterName] Maybe Type
forall a. Maybe a
Nothing Con
con [DerivClause
deriveGN, DerivClause
deriveStockClause, DerivClause
deriveAnyClassClause]]
    ProductType (DatatypeName datatypeName :: FilePath
datatypeName) named :: Named
named children :: Maybe Children
children fields :: [(FilePath, Field)]
fields -> do
      Con
con <- FilePath -> Name -> Maybe Children -> [(FilePath, Field)] -> ConQ
ctorForProductType FilePath
datatypeName Name
typeParameterName Maybe Children
children [(FilePath, Field)]
fields
      [Dec]
result <- [(FilePath, Named)] -> Name -> Named -> FilePath -> Q [Dec]
symbolMatchingInstance [(FilePath, Named)]
allSymbols Name
name Named
named FilePath
datatypeName
      [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Name -> [Con] -> Name -> Dec
generatedDatatype Name
name [Con
con] Name
typeParameterNameDec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[Dec]
result
      -- Anonymous leaf types are defined as synonyms for the `Token` datatype
    LeafType (DatatypeName datatypeName :: FilePath
datatypeName) Anonymous -> do
      TSSymbol
tsSymbol <- IO TSSymbol -> Q TSSymbol
forall a. IO a -> Q a
runIO (IO TSSymbol -> Q TSSymbol) -> IO TSSymbol -> Q TSSymbol
forall a b. (a -> b) -> a -> b
$ FilePath -> (CStringLen -> IO TSSymbol) -> IO TSSymbol
forall a. FilePath -> (CStringLen -> IO a) -> IO a
withCStringLen FilePath
datatypeName (\(s :: CString
s, len :: Int
len) -> Ptr Language -> CString -> Int -> Bool -> IO TSSymbol
TS.ts_language_symbol_for_name Ptr Language
language CString
s Int
len Bool
False)
      [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Name -> [TyVarBndr] -> Type -> Dec
TySynD Name
name [] (Name -> Type
ConT ''Token Type -> Type -> Type
`AppT` TyLit -> Type
LitT (FilePath -> TyLit
StrTyLit FilePath
datatypeName) Type -> Type -> Type
`AppT` TyLit -> Type
LitT (Integer -> TyLit
NumTyLit (TSSymbol -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral TSSymbol
tsSymbol))) ]
    LeafType (DatatypeName datatypeName :: FilePath
datatypeName) Named -> do
      Con
con <- DatatypeName -> Name -> ConQ
ctorForLeafType (FilePath -> DatatypeName
DatatypeName FilePath
datatypeName) Name
typeParameterName
      [Dec]
result <- [(FilePath, Named)] -> Name -> Named -> FilePath -> Q [Dec]
symbolMatchingInstance [(FilePath, Named)]
allSymbols Name
name Named
Named FilePath
datatypeName
      [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Name -> [Con] -> Name -> Dec
generatedDatatype Name
name [Con
con] Name
typeParameterNameDec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[Dec]
result
  where
    -- Skip generating datatypes that have already been defined (overridden) in the module where the splice is running.
    skipDefined :: Q [a] -> Q [a]
skipDefined m :: Q [a]
m = do
      Bool
isLocal <- FilePath -> Q (Maybe Name)
lookupTypeName FilePath
nameStr Q (Maybe Name) -> (Maybe Name -> Q Bool) -> Q Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Q Bool -> (Name -> Q Bool) -> Maybe Name -> Q Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) Name -> Q Bool
isLocalName
      if Bool
isLocal then [a] -> Q [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] else Q [a]
m
    name :: Name
name = FilePath -> Name
mkName FilePath
nameStr
    nameStr :: FilePath
nameStr = Named -> FilePath -> FilePath
toNameString (Datatype -> Named
datatypeNameStatus Datatype
datatype) (DatatypeName -> FilePath
getDatatypeName (Datatype -> DatatypeName
TreeSitter.Deserialize.datatypeName Datatype
datatype))
    deriveStockClause :: DerivClause
deriveStockClause = Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
StockStrategy) [ Name -> Type
ConT ''Eq, Name -> Type
ConT ''Ord, Name -> Type
ConT ''Show, Name -> Type
ConT ''Generic, Name -> Type
ConT ''Foldable, Name -> Type
ConT ''Functor, Name -> Type
ConT ''Traversable, Name -> Type
ConT ''Generic1]
    deriveAnyClassClause :: DerivClause
deriveAnyClassClause = Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
AnyclassStrategy) [Name -> Type
ConT ''TS.Unmarshal]
    deriveGN :: DerivClause
deriveGN = Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
NewtypeStrategy) [Name -> Type
ConT ''TS.SymbolMatching]
    generatedDatatype :: Name -> [Con] -> Name -> Dec
generatedDatatype name :: Name
name cons :: [Con]
cons typeParameterName :: Name
typeParameterName = Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
name [Name -> TyVarBndr
PlainTV Name
typeParameterName] Maybe Type
forall a. Maybe a
Nothing [Con]
cons [DerivClause
deriveStockClause, DerivClause
deriveAnyClassClause]


-- | Create TH-generated SymbolMatching instances for sums, products, leaves
symbolMatchingInstance :: [(String, Named)] -> Name -> Named -> String -> Q [Dec]
symbolMatchingInstance :: [(FilePath, Named)] -> Name -> Named -> FilePath -> Q [Dec]
symbolMatchingInstance allSymbols :: [(FilePath, Named)]
allSymbols name :: Name
name named :: Named
named str :: FilePath
str = do
  let tsSymbols :: [Int]
tsSymbols = (FilePath, Named) -> [(FilePath, Named)] -> [Int]
forall a. Eq a => a -> [a] -> [Int]
elemIndices (FilePath
str, Named
named) [(FilePath, Named)]
allSymbols
      names :: FilePath
names = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate ", " ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ (Int -> FilePath) -> [Int] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath, Named) -> FilePath
debugPrefix ((FilePath, Named) -> FilePath)
-> (Int -> (FilePath, Named)) -> Int -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FilePath, Named)] -> Int -> (FilePath, Named)
forall a. [a] -> Int -> a
(!!) [(FilePath, Named)]
allSymbols) [Int]
tsSymbols
  [d|instance TS.SymbolMatching $(conT name) where
      showFailure _ node = "expected " <> $(litE (stringL (show names))) <> " but got " <> show (debugSymbolNames !! fromIntegral (nodeSymbol node))
      symbolMatch _ node = elem (nodeSymbol node) tsSymbols|]

-- | Prefix symbol names for debugging to disambiguate between Named and Anonymous nodes.
debugPrefix :: (String, Named) -> String
debugPrefix :: (FilePath, Named) -> FilePath
debugPrefix (name :: FilePath
name, Named)     = FilePath
name
debugPrefix (name :: FilePath
name, Anonymous) = "_" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
name

-- | Build Q Constructor for product types (nodes with fields)
ctorForProductType :: String -> Name -> Maybe Children -> [(String, Field)] -> Q Con
ctorForProductType :: FilePath -> Name -> Maybe Children -> [(FilePath, Field)] -> ConQ
ctorForProductType constructorName :: FilePath
constructorName typeParameterName :: Name
typeParameterName children :: Maybe Children
children fields :: [(FilePath, Field)]
fields = FilePath -> [(FilePath, Q Type)] -> ConQ
ctorForTypes FilePath
constructorName [(FilePath, Q Type)]
lists where
  lists :: [(FilePath, Q Type)]
lists = (FilePath, Q Type)
annotation (FilePath, Q Type) -> [(FilePath, Q Type)] -> [(FilePath, Q Type)]
forall a. a -> [a] -> [a]
: [(FilePath, Q Type)]
fieldList [(FilePath, Q Type)]
-> [(FilePath, Q Type)] -> [(FilePath, Q Type)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, Q Type)]
childList
  annotation :: (FilePath, Q Type)
annotation = ("ann", Name -> Q Type
varT Name
typeParameterName)
  fieldList :: [(FilePath, Q Type)]
fieldList = ((FilePath, Field) -> (FilePath, Q Type))
-> [(FilePath, Field)] -> [(FilePath, Q Type)]
forall a b. (a -> b) -> [a] -> [b]
map ((Field -> Q Type) -> (FilePath, Field) -> (FilePath, Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Field -> Q Type
toType) [(FilePath, Field)]
fields
  childList :: [(FilePath, Q Type)]
childList = Maybe (FilePath, Q Type) -> [(FilePath, Q Type)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe (FilePath, Q Type) -> [(FilePath, Q Type)])
-> Maybe (FilePath, Q Type) -> [(FilePath, Q Type)]
forall a b. (a -> b) -> a -> b
$ (Children -> (FilePath, Q Type))
-> Maybe Children -> Maybe (FilePath, Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Children -> (FilePath, Q Type)
toTypeChild Maybe Children
children
  toType :: Field -> Q Type
toType (MkField required :: Required
required fieldTypes :: NonEmpty Type
fieldTypes mult :: Multiple
mult) =
    let ftypes :: Q Type
ftypes = NonEmpty Type -> Q Type
fieldTypesToNestedSum NonEmpty Type
fieldTypes Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
typeParameterName
    in case (Required
required, Multiple
mult) of
      (Required, Multiple) -> Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT ''NonEmpty) Q Type
ftypes
      (Required, Single) -> Q Type
ftypes
      (Optional, Multiple) -> Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT ''[]) Q Type
ftypes
      (Optional, Single) -> Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT ''Maybe) Q Type
ftypes
  toTypeChild :: Children -> (FilePath, Q Type)
toTypeChild (MkChildren field :: Field
field) = ("extra_children", Field -> Q Type
toType Field
field)

-- | Build Q Constructor for leaf types (nodes with no fields or subtypes)
ctorForLeafType :: DatatypeName -> Name -> Q Con
ctorForLeafType :: DatatypeName -> Name -> ConQ
ctorForLeafType (DatatypeName name :: FilePath
name) typeParameterName :: Name
typeParameterName = FilePath -> [(FilePath, Q Type)] -> ConQ
ctorForTypes FilePath
name
  [ ("ann",  Name -> Q Type
varT Name
typeParameterName) -- ann :: a
  , ("text", Name -> Q Type
conT ''Text)            -- text :: Text
  ]

-- | Build Q Constructor for records
ctorForTypes :: String -> [(String, Q TH.Type)] -> Q Con
ctorForTypes :: FilePath -> [(FilePath, Q Type)] -> ConQ
ctorForTypes constructorName :: FilePath
constructorName types :: [(FilePath, Q Type)]
types = Name -> [VarBangTypeQ] -> ConQ
recC (Named -> FilePath -> Name
toName Named
Named FilePath
constructorName) [VarBangTypeQ]
recordFields where
  recordFields :: [VarBangTypeQ]
recordFields = ((FilePath, Q Type) -> VarBangTypeQ)
-> [(FilePath, Q Type)] -> [VarBangTypeQ]
forall a b. (a -> b) -> [a] -> [b]
map ((FilePath -> Q Type -> VarBangTypeQ)
-> (FilePath, Q Type) -> VarBangTypeQ
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FilePath -> Q Type -> VarBangTypeQ
toVarBangType) [(FilePath, Q Type)]
types
  toVarBangType :: FilePath -> Q Type -> VarBangTypeQ
toVarBangType str :: FilePath
str type' :: Q Type
type' = Name -> BangTypeQ -> VarBangTypeQ
TH.varBangType (FilePath -> Name
mkName (FilePath -> Name) -> (FilePath -> FilePath) -> FilePath -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
toHaskellCamelCaseIdentifier (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ FilePath
str) (BangQ -> Q Type -> BangTypeQ
TH.bangType BangQ
strictness Q Type
type')


-- | Convert field types to Q types
fieldTypesToNestedSum :: NonEmpty TreeSitter.Deserialize.Type -> Q TH.Type
fieldTypesToNestedSum :: NonEmpty Type -> Q Type
fieldTypesToNestedSum xs :: NonEmpty Type
xs = [Type] -> Q Type
go (NonEmpty Type -> [Type]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Type
xs)
  where
    combine :: Q Type -> Q Type -> Q Type
combine lhs :: Q Type
lhs rhs :: Q Type
rhs = (Name -> Q Type
conT ''(:+:) Q Type -> Q Type -> Q Type
`appT` Q Type
lhs) Q Type -> Q Type -> Q Type
`appT` Q Type
rhs -- (((((a :+: b) :+: c) :+: d)) :+: e)   ((a :+: b) :+: (c :+: d))
    convertToQType :: Type -> Q Type
convertToQType (MkType (DatatypeName n :: FilePath
n) named :: Named
named) = Name -> Q Type
conT (Named -> FilePath -> Name
toName Named
named FilePath
n)
    go :: [Type] -> Q Type
go [x :: Type
x] = Type -> Q Type
convertToQType Type
x
    go xs :: [Type]
xs = let (l :: [Type]
l,r :: [Type]
r) = Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
xs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2) [Type]
xs in (Q Type -> Q Type -> Q Type
combine ([Type] -> Q Type
go [Type]
l) ([Type] -> Q Type
go [Type]
r))


-- | Create bang required to build records
strictness :: BangQ
strictness :: BangQ
strictness = SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
TH.bang SourceUnpackednessQ
noSourceUnpackedness SourceStrictnessQ
noSourceStrictness

-- | Prepend "Anonymous" to named node when false, otherwise use regular toName
toName :: Named -> String -> Name
toName :: Named -> FilePath -> Name
toName named :: Named
named str :: FilePath
str = FilePath -> Name
mkName (Named -> FilePath -> FilePath
toNameString Named
named FilePath
str)

toNameString :: Named -> String -> String
toNameString :: Named -> FilePath -> FilePath
toNameString named :: Named
named str :: FilePath
str = Named -> FilePath
prefix Named
named FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> FilePath
toHaskellPascalCaseIdentifier FilePath
str
  where
    prefix :: Named -> FilePath
prefix Anonymous = "Anonymous"
    prefix Named     = ""

-- | Get the 'Module', if any, for a given 'Name'.
moduleForName :: Name -> Maybe Module
moduleForName :: Name -> Maybe Module
moduleForName n :: Name
n = PkgName -> ModName -> Module
Module (PkgName -> ModName -> Module)
-> (FilePath -> PkgName) -> FilePath -> ModName -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> PkgName
PkgName (FilePath -> ModName -> Module)
-> Maybe FilePath -> Maybe (ModName -> Module)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Maybe FilePath
namePackage Name
n Maybe (ModName -> Module) -> Maybe ModName -> Maybe Module
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FilePath -> ModName
ModName (FilePath -> ModName) -> Maybe FilePath -> Maybe ModName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Maybe FilePath
nameModule Name
n)

-- | Test whether the name is defined in the module where the splice is executed.
isLocalName :: Name -> Q Bool
isLocalName :: Name -> Q Bool
isLocalName n :: Name
n = (Name -> Maybe Module
moduleForName Name
n Maybe Module -> Maybe Module -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe Module -> Bool)
-> (Module -> Maybe Module) -> Module -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> Maybe Module
forall a. a -> Maybe a
Just (Module -> Bool) -> Q Module -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Module
thisModule