{-# 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 -> Ptr Language -> Q [Dec]
mkSymbolDatatype Name
name Ptr Language
language = do
  [(SymbolType, String)]
symbols <- [(SymbolType, String)] -> [(SymbolType, String)]
forall a. [(a, String)] -> [(a, String)]
renameDups ([(SymbolType, String)] -> [(SymbolType, String)])
-> ([(SymbolType, String)] -> [(SymbolType, String)])
-> [(SymbolType, String)]
-> [(SymbolType, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((SymbolType, String) -> (SymbolType, String))
-> [(SymbolType, String)] -> [(SymbolType, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((,) (SymbolType -> String -> (SymbolType, String))
-> ((SymbolType, String) -> SymbolType)
-> (SymbolType, String)
-> String
-> (SymbolType, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SymbolType, String) -> SymbolType
forall a b. (a, b) -> a
fst ((SymbolType, String) -> String -> (SymbolType, String))
-> ((SymbolType, String) -> String)
-> (SymbolType, String)
-> (SymbolType, String)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (SymbolType -> String -> String) -> (SymbolType, String) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SymbolType -> String -> String
symbolToName) ([(SymbolType, String)] -> [(SymbolType, String)])
-> ([(SymbolType, String)] -> [(SymbolType, String)])
-> [(SymbolType, String)]
-> [(SymbolType, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(SymbolType, String)]
-> [(SymbolType, String)] -> [(SymbolType, String)]
forall a. [a] -> [a] -> [a]
++ [(SymbolType
Regular, String
"ParseError")]) ([(SymbolType, String)] -> [(SymbolType, String)])
-> Q [(SymbolType, String)] -> Q [(SymbolType, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(SymbolType, String)] -> Q [(SymbolType, String)]
forall a. IO a -> Q a
runIO (Ptr Language -> IO [(SymbolType, String)]
languageSymbols Ptr Language
language)
  Module PkgName
_ ModName
modName <- Q Module
thisModule
  let mkMatch :: t -> String -> m Match
mkMatch t
symbolType String
str = m Pat -> m Body -> [m Dec] -> m Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [m Pat] -> m Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (OccName -> NameFlavour -> Name
Name (String -> OccName
OccName String
str) (ModName -> NameFlavour
NameQ ModName
modName)) []) (m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [e|symbolType|]) []
  Dec
datatype <- Q Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Kind
-> [Q Con]
-> [Q DerivClause]
-> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Kind
-> [m Con]
-> [m DerivClause]
-> m Dec
dataD (Cxt -> Q Cxt
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) Name
name [] Maybe Kind
forall a. Maybe a
Nothing ((Name -> [Q BangType] -> Q Con) -> [Q BangType] -> Name -> Q Con
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> [Q BangType] -> Q Con
forall (m :: * -> *). Quote m => Name -> [m BangType] -> m Con
normalC [] (Name -> Q Con)
-> ((SymbolType, String) -> Name) -> (SymbolType, String) -> Q Con
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Name)
-> ((SymbolType, String) -> String) -> (SymbolType, String) -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SymbolType, String) -> String
forall a b. (a, b) -> b
snd ((SymbolType, String) -> Q Con)
-> [(SymbolType, String)] -> [Q Con]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SymbolType, String)]
symbols)
    [ Maybe DerivStrategy -> [Q Kind] -> Q DerivClause
forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> [m Kind] -> m DerivClause
derivClause Maybe DerivStrategy
forall a. Maybe a
Nothing ((Name -> Q Kind) -> [Name] -> [Q Kind]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT [ ''Bounded, ''Enum, ''Eq, ''Ix, ''Ord, ''Show ]) ]
  [Dec]
symbolInstance <- [d|
    instance Symbol $(conT name) where
      symbolType = $(lamCaseE (uncurry mkMatch <$> symbols)) |]
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
datatype Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
symbolInstance)

renameDups :: [(a, String)] -> [(a, String)]
renameDups :: forall a. [(a, String)] -> [(a, String)]
renameDups = (Set String, [(a, String)]) -> [(a, String)]
forall a b. (a, b) -> b
snd ((Set String, [(a, String)]) -> [(a, String)])
-> ([(a, String)] -> (Set String, [(a, String)]))
-> [(a, String)]
-> [(a, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set String -> (a, String) -> (Set String, (a, String)))
-> Set String -> [(a, String)] -> (Set String, [(a, String)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Set String -> (a, String) -> (Set String, (a, String))
forall {a}. Set String -> (a, String) -> (Set String, (a, String))
go Set String
forall a. Monoid a => a
mempty
  where go :: Set String -> (a, String) -> (Set String, (a, String))
go Set String
done (a
ty, String
name) = let name' :: String
name' = String -> String
rename String
name in (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert String
name' Set String
done, (a
ty, String
name'))
          where rename :: String -> String
rename String
name | String
name String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
done = String -> String
rename (String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'")
                            | Bool
otherwise              = String
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 :: String -> Q [Dec]
addDependentFileRelative String
relativeFile = do
    String
currentFilename <- Loc -> String
loc_filename (Loc -> String) -> Q Loc -> Q String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Loc
location
    String
pwd             <- IO String -> Q String
forall a. IO a -> Q a
runIO IO String
getCurrentDirectory

    let invocationRelativePath :: String
invocationRelativePath = String -> String
takeDirectory (String
pwd String -> String -> String
</> String
currentFilename) String -> String -> String
</> String
relativeFile

    String -> Q ()
addDependentFile String
invocationRelativePath

    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []


languageSymbols :: Ptr Language -> IO [(SymbolType, String)]
languageSymbols :: Ptr Language -> IO [(SymbolType, String)]
languageSymbols Ptr Language
language = Ptr Language -> IO Word32
ts_language_symbol_count Ptr Language
language IO Word32
-> (Word32 -> IO [(SymbolType, String)])
-> IO [(SymbolType, String)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Word32
count -> [TSSymbol]
-> (TSSymbol -> IO (SymbolType, String))
-> IO [(SymbolType, String)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [TSSymbol
0..Word32 -> TSSymbol
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word32
forall a. Enum a => a -> a
pred Word32
count)] ((TSSymbol -> IO (SymbolType, String))
 -> IO [(SymbolType, String)])
-> (TSSymbol -> IO (SymbolType, String))
-> IO [(SymbolType, String)]
forall a b. (a -> b) -> a -> b
$ \ TSSymbol
symbol -> do
  CString
cname <- Ptr Language -> TSSymbol -> IO CString
ts_language_symbol_name Ptr Language
language TSSymbol
symbol
  String
name <- CString -> IO String
peekCString CString
cname
  SymbolType
ty <- Int -> SymbolType
forall a. Enum a => Int -> a
toEnum (Int -> SymbolType) -> IO Int -> IO SymbolType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Language -> TSSymbol -> IO Int
ts_language_symbol_type Ptr Language
language TSSymbol
symbol
  (SymbolType, String) -> IO (SymbolType, String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SymbolType
ty, String
name)