content: {-# LANGUAGE TemplateHaskell #-}
  module TreeSitter.Language
  ( module TreeSitter.Language
  , module TreeSitter.Symbol
  ) where
  
  import           Data.Ix (Ix)
  import           Data.List (mapAccumL)
  import qualified Data.Set as Set
  import           Data.Traversable (for)
  import           Data.Word
  import           Foreign.C.String
  import           Foreign.Ptr
  import           Language.Haskell.TH
  import           Language.Haskell.TH.Syntax
  import           System.Directory
  import           System.FilePath.Posix
  import           TreeSitter.Symbol
  
  -- | A tree-sitter language.
  --
  --   This type is uninhabited and used only for type safety within 'Ptr' values.
  data Language
  
  foreign import ccall unsafe "ts_language_symbol_count" ts_language_symbol_count :: Ptr Language -> IO Word32
  foreign import ccall unsafe "ts_language_symbol_name" ts_language_symbol_name :: Ptr Language -> TSSymbol -> IO CString
  foreign import ccall unsafe "ts_language_symbol_type" ts_language_symbol_type :: Ptr Language -> TSSymbol -> IO Int
  foreign import ccall unsafe "ts_language_symbol_for_name" ts_language_symbol_for_name :: Ptr Language -> CString -> Int -> Bool -> IO TSSymbol
  
  -- | TemplateHaskell construction of a datatype for the referenced Language.
  mkSymbolDatatype :: Name -> Ptr Language -> Q [Dec]
  mkSymbolDatatype name language = do
    symbols <- renameDups . map ((,) . fst <*> uncurry symbolToName) . (++ [(Regular, "ParseError")]) <$> runIO (languageSymbols language)
    Module _ modName <- thisModule
    let mkMatch symbolType str = match (conP (Name (OccName str) (NameQ modName)) []) (normalB [e|symbolType|]) []
    datatype <- dataD (pure []) name [] Nothing (flip normalC [] . mkName . snd <$> symbols)
      [ derivClause Nothing (map conT [ ''Bounded, ''Enum, ''Eq, ''Ix, ''Ord, ''Show ]) ]
    symbolInstance <- [d|
      instance Symbol $(conT name) where
        symbolType = $(lamCaseE (uncurry mkMatch <$> symbols)) |]
    pure (datatype : symbolInstance)
  
  renameDups :: [(a, String)] -> [(a, String)]
  renameDups = snd . mapAccumL go mempty
    where go done (ty, name) = let name' = rename name in (Set.insert name' done, (ty, name'))
            where rename name | name `Set.member` done = rename (name ++ "'")
                              | otherwise              = name
  
  -- https://stackoverflow.com/questions/16163948/how-do-i-use-templatehaskells-adddependentfile-on-a-file-relative-to-the-file-b
  addDependentFileRelative :: FilePath -> Q [Dec]
  addDependentFileRelative relativeFile = do
      currentFilename <- loc_filename <$> location
      pwd             <- runIO getCurrentDirectory
  
      let invocationRelativePath = takeDirectory (pwd </> currentFilename) </> relativeFile
  
      addDependentFile invocationRelativePath
  
      return []
  
  
  languageSymbols :: Ptr Language -> IO [(SymbolType, String)]
  languageSymbols language = ts_language_symbol_count language >>= \ count -> for [0..fromIntegral (pred count)] $ \ symbol -> do
    cname <- ts_language_symbol_name language symbol
    name <- peekCString cname
    ty <- toEnum <$> ts_language_symbol_type language symbol
    pure (ty, name)
  