{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}

{-|
Module      :  Language.C.Clang.Cursor.Typed
Copyright   :  (C) 2016 Patrick Chilton

This module contains a typed version of "Language.C.Clang.Cursor".
Here, we keep track of `CursorKind`s at type-level, which means
that you don't need to check whether a `Cursor` has a given property at runtime.
-}
module Language.C.Clang.Cursor.Typed
  ( Cursor
  , CursorK()
  , withoutKind
  , matchKind

  , translationUnitCursor

  , cursorType

  , cursorChildrenF
  , cursorChildren
  , cursorDescendantsF
  , cursorDescendants

  , cursorExtent
  , cursorLocation

  , cursorSpelling

  , TypeLayoutError(..)
  , offsetOfField

  , HasType
  , HasChildren
  , HasExtent
  , HasSpelling
  , CursorKind(..)
  ) where

import qualified Data.ByteString as BS
import           Data.Functor.Contravariant
import           Data.Maybe
import           Data.Singletons
import           Data.Word
import           Lens.Micro.Contra

import qualified Language.C.Clang.Cursor as UT
import           Language.C.Clang.Cursor ( cursorKind, Cursor, CursorKind(..) )
import           Language.C.Clang.Location
import           Language.C.Clang.Internal.Types

import           Language.C.Clang.Internal.Refs (Clang)

-- | A `Cursor` with a statically known `CursorKind`.
newtype CursorK (kind :: CursorKind) = CursorK { withoutKind :: Cursor }
  deriving (Eq, Clang, Show)

-- | Match a `Cursor` as a particular `CursorKind`. You can use the @TypeApplications@ extension to easily specify the `CursorKind` you want: @matchKind \@'StructDecl@.
matchKind :: forall kind. SingI kind => Cursor -> Maybe (CursorK kind)
matchKind c
  | cursorKind c == fromSing (sing :: Sing kind) = Just (CursorK c)
  | otherwise = Nothing

translationUnitCursor :: TranslationUnit -> CursorK 'TranslationUnit
translationUnitCursor = CursorK . UT.translationUnitCursor

class HasType (kind :: CursorKind)
cursorType :: HasType kind => CursorK kind -> Type
cursorType = fromJust . UT.cursorType . withoutKind

class HasChildren (kind :: CursorKind)

to :: (s -> a) -> Getter s a
to k f = phantom . f . k

cursorChildrenF :: HasChildren kind => Fold (CursorK kind) Cursor
cursorChildrenF = to withoutKind . UT.cursorChildrenF

cursorChildren :: HasChildren kind => CursorK kind -> [ Cursor ]
cursorChildren = UT.cursorChildren . withoutKind

-- | `Fold` over a `CursorK` and all of its descendants recursively.
cursorDescendantsF :: HasChildren kind => Fold (CursorK kind) Cursor
cursorDescendantsF = to withoutKind . UT.cursorDescendantsF

-- | List a `CursorK` and all of its descendants recursively.
cursorDescendants :: HasChildren kind => CursorK kind -> [ Cursor ]
cursorDescendants = UT.cursorDescendants . withoutKind

class HasExtent (kind :: CursorKind)

cursorExtent :: HasExtent kind => CursorK kind -> SourceRange
cursorExtent = fromJust . UT.cursorExtent . withoutKind

cursorLocation :: CursorK kind -> SourceLocation
cursorLocation = UT.cursorLocation . withoutKind

class HasSpelling (kind :: CursorKind)

cursorSpelling :: HasSpelling kind => CursorK kind -> BS.ByteString
cursorSpelling = UT.cursorSpelling . withoutKind

offsetOfField :: CursorK 'FieldDecl -> Either TypeLayoutError Word64
offsetOfField = UT.offsetOfField . withoutKind

-- instances derived experimentally with the find-classes executable
instance HasChildren 'ArraySubscriptExpr
instance HasChildren 'BinaryOperator
instance HasChildren 'CStyleCastExpr
instance HasChildren 'CXXBaseSpecifier
instance HasChildren 'CXXCatchStmt
instance HasChildren 'CXXConstCastExpr
instance HasChildren 'CXXDeleteExpr
instance HasChildren 'CXXDynamicCastExpr
instance HasChildren 'CXXFunctionalCastExpr
instance HasChildren 'CXXMethod
instance HasChildren 'CXXNewExpr
instance HasChildren 'CXXReinterpretCastExpr
instance HasChildren 'CXXStaticCastExpr
instance HasChildren 'CXXTryStmt
instance HasChildren 'CallExpr
instance HasChildren 'CaseStmt
instance HasChildren 'ClassDecl
instance HasChildren 'ClassTemplate
instance HasChildren 'ClassTemplatePartialSpecialization
instance HasChildren 'CompoundAssignOperator
instance HasChildren 'CompoundStmt
instance HasChildren 'ConditionalOperator
instance HasChildren 'Constructor
instance HasChildren 'ConversionFunction
instance HasChildren 'DeclRefExpr
instance HasChildren 'DeclStmt
instance HasChildren 'DefaultStmt
instance HasChildren 'Destructor
instance HasChildren 'DoStmt
instance HasChildren 'EnumConstantDecl
instance HasChildren 'EnumDecl
instance HasChildren 'FieldDecl
instance HasChildren 'FirstExpr
instance HasChildren 'ForStmt
instance HasChildren 'FunctionDecl
instance HasChildren 'FunctionTemplate
instance HasChildren 'IfStmt
instance HasChildren 'InitListExpr
instance HasChildren 'MemberRefExpr
instance HasChildren 'Namespace
instance HasChildren 'NonTypeTemplateParameter
instance HasChildren 'ParenExpr
instance HasChildren 'ParmDecl
instance HasChildren 'ReturnStmt
instance HasChildren 'StructDecl
instance HasChildren 'SwitchStmt
instance HasChildren 'TemplateTypeParameter
instance HasChildren 'TranslationUnit
instance HasChildren 'TypedefDecl
instance HasChildren 'UnaryOperator
instance HasChildren 'UnexposedDecl
instance HasChildren 'UnionDecl
instance HasChildren 'UsingDeclaration
instance HasChildren 'UsingDirective
instance HasChildren 'VarDecl
instance HasChildren 'WhileStmt

instance HasType 'ArraySubscriptExpr
instance HasType 'BinaryOperator
instance HasType 'CStyleCastExpr
instance HasType 'CXXBaseSpecifier
instance HasType 'CXXBoolLiteralExpr
instance HasType 'CXXConstCastExpr
instance HasType 'CXXDeleteExpr
instance HasType 'CXXDynamicCastExpr
instance HasType 'CXXFunctionalCastExpr
instance HasType 'CXXMethod
instance HasType 'CXXNewExpr
instance HasType 'CXXReinterpretCastExpr
instance HasType 'CXXStaticCastExpr
instance HasType 'CXXThisExpr
instance HasType 'CXXThrowExpr
instance HasType 'CallExpr
instance HasType 'CharacterLiteral
instance HasType 'ClassDecl
instance HasType 'ClassTemplatePartialSpecialization
instance HasType 'CompoundAssignOperator
instance HasType 'ConditionalOperator
instance HasType 'Constructor
instance HasType 'ConversionFunction
instance HasType 'DeclRefExpr
instance HasType 'Destructor
instance HasType 'EnumConstantDecl
instance HasType 'EnumDecl
instance HasType 'FieldDecl
instance HasType 'FloatingLiteral
instance HasType 'FunctionDecl
instance HasType 'FunctionTemplate
instance HasType 'GNUNullExpr
instance HasType 'InitListExpr
instance HasType 'IntegerLiteral
instance HasType 'MemberRef
instance HasType 'MemberRefExpr
instance HasType 'NonTypeTemplateParameter
instance HasType 'ParenExpr
instance HasType 'ParmDecl
instance HasType 'StringLiteral
instance HasType 'StructDecl
instance HasType 'TemplateTypeParameter
instance HasType 'TypeRef
instance HasType 'TypedefDecl
instance HasType 'UnaryOperator
instance HasType 'UnionDecl
instance HasType 'VarDecl

instance HasExtent 'ArraySubscriptExpr
instance HasExtent 'AsmLabelAttr
instance HasExtent 'BinaryOperator
instance HasExtent 'BreakStmt
instance HasExtent 'CStyleCastExpr
instance HasExtent 'CXXAccessSpecifier
instance HasExtent 'CXXBaseSpecifier
instance HasExtent 'CXXBoolLiteralExpr
instance HasExtent 'CXXCatchStmt
instance HasExtent 'CXXConstCastExpr
instance HasExtent 'CXXDeleteExpr
instance HasExtent 'CXXDynamicCastExpr
instance HasExtent 'CXXFunctionalCastExpr
instance HasExtent 'CXXMethod
instance HasExtent 'CXXNewExpr
instance HasExtent 'CXXReinterpretCastExpr
instance HasExtent 'CXXStaticCastExpr
instance HasExtent 'CXXThisExpr
instance HasExtent 'CXXThrowExpr
instance HasExtent 'CXXTryStmt
instance HasExtent 'CallExpr
instance HasExtent 'CaseStmt
instance HasExtent 'CharacterLiteral
instance HasExtent 'ClassDecl
instance HasExtent 'ClassTemplate
instance HasExtent 'ClassTemplatePartialSpecialization
instance HasExtent 'CompoundAssignOperator
instance HasExtent 'CompoundStmt
instance HasExtent 'ConditionalOperator
instance HasExtent 'ConstAttr
instance HasExtent 'Constructor
instance HasExtent 'ContinueStmt
instance HasExtent 'ConversionFunction
instance HasExtent 'DeclRefExpr
instance HasExtent 'DeclStmt
instance HasExtent 'DefaultStmt
instance HasExtent 'Destructor
instance HasExtent 'DoStmt
instance HasExtent 'EnumConstantDecl
instance HasExtent 'EnumDecl
instance HasExtent 'FloatingLiteral
instance HasExtent 'ForStmt
instance HasExtent 'FunctionDecl
instance HasExtent 'FunctionTemplate
instance HasExtent 'GNUNullExpr
instance HasExtent 'IfStmt
instance HasExtent 'InitListExpr
instance HasExtent 'MemberRef
instance HasExtent 'MemberRefExpr
instance HasExtent 'Namespace
instance HasExtent 'NamespaceRef
instance HasExtent 'NonTypeTemplateParameter
instance HasExtent 'NullStmt
instance HasExtent 'OverloadedDeclRef
instance HasExtent 'ParenExpr
instance HasExtent 'PureAttr
instance HasExtent 'ReturnStmt
instance HasExtent 'StringLiteral
instance HasExtent 'StructDecl
instance HasExtent 'SwitchStmt
instance HasExtent 'TemplateRef
instance HasExtent 'TemplateTypeParameter
instance HasExtent 'TranslationUnit
instance HasExtent 'TypeRef
instance HasExtent 'TypedefDecl
instance HasExtent 'UnaryOperator
instance HasExtent 'UnionDecl
instance HasExtent 'UsingDeclaration
instance HasExtent 'UsingDirective
instance HasExtent 'WhileStmt

instance HasSpelling 'AsmLabelAttr
instance HasSpelling 'CXXBaseSpecifier
instance HasSpelling 'CXXMethod
instance HasSpelling 'ClassDecl
instance HasSpelling 'ClassTemplate
instance HasSpelling 'ClassTemplatePartialSpecialization
instance HasSpelling 'Constructor
instance HasSpelling 'ConversionFunction
instance HasSpelling 'Destructor
instance HasSpelling 'EnumConstantDecl
instance HasSpelling 'FieldDecl
instance HasSpelling 'FunctionDecl
instance HasSpelling 'FunctionTemplate
instance HasSpelling 'MemberRef
instance HasSpelling 'Namespace
instance HasSpelling 'NamespaceRef
instance HasSpelling 'OverloadedDeclRef
instance HasSpelling 'StringLiteral
instance HasSpelling 'StructDecl
instance HasSpelling 'TemplateRef
instance HasSpelling 'TranslationUnit
instance HasSpelling 'TypeRef
instance HasSpelling 'TypedefDecl
instance HasSpelling 'UsingDeclaration