{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE TypeApplications  #-}

{-|
Module      : Headroom.FileSupport.Haskell
Description : Support for /Haskell/ source code files
Copyright   : (c) 2019-2021 Vaclav Svejcar
License     : BSD-3-Clause
Maintainer  : vaclav.svejcar@gmail.com
Stability   : experimental
Portability : POSIX

Support for /Haskell/ source code files. This implementation extracts module
name and /Haddock/ fields as variables (see below). For more details about
/Haddock/ extraction, see "Headroom.FileSupport.Haskell.Haddock" module.

= Extracted Variables for Templates
This implementation extracts following variables from source code file:

* @___haskell_module_copyright__@ - @Copyright@ field of /Haddock/ module header
* @___haskell_module_license__@ - @License@ field of /Haddock/ module header
* @___haskell_module_maintainer__@ - @Maintainer@ field of /Haddock/ module header
* @___haskell_module_portability__@ - @Portability@ field of /Haddock/ module header
* @___haskell_module_stability__@ - @Stability@ field of /Haddock/ module header
* @___haskell_module_name__@ - name of the /Haskell/ module
* @___haskell_module_longdesc__@ - long description of /Haddock/ module
* @___haskell_module_shortdesc__@ - @Description@ field of /Haddock/ module header

= Extracted Custom Data
This implementation extracts custom data from used template, represented by the
'HaskellTemplateData'' data type.
-}

module Headroom.FileSupport.Haskell
  ( fileSupport
  )
where

import           Headroom.Data.Regex                 ( isMatch
                                                     , match
                                                     , re
                                                     )
import           Headroom.FileSupport.Haskell.Haddock
                                                     ( HaddockModuleHeader(..)
                                                     , extractModuleHeader
                                                     , extractOffsets
                                                     )
import           Headroom.FileSupport.TemplateData   ( HaskellTemplateData'(..)
                                                     , TemplateData(..)
                                                     )
import           Headroom.FileSupport.Types          ( FileSupport(..)
                                                     , SyntaxAnalysis(..)
                                                     )

import           Headroom.Configuration.Types        ( HeaderConfig(..)
                                                     , HeaderSyntax
                                                     )
import           Headroom.FileType.Types             ( FileType(..) )
import           Headroom.Header.Types               ( HeaderTemplate(..) )
import           Headroom.SourceCode                 ( LineType(..)
                                                     , SourceCode(..)
                                                     , cut
                                                     , firstMatching
                                                     )
import           Headroom.Template                   ( Template(..) )
import           Headroom.Variables                  ( mkVariables )
import           Headroom.Variables.Types            ( Variables(..) )
import           RIO
import           RIO.Lens                            ( ix )



------------------------------  PUBLIC FUNCTIONS  ------------------------------

-- | Implementation of 'FileSupport' for /Haskell/.
fileSupport :: FileSupport
fileSupport :: FileSupport
fileSupport = FileSupport :: SyntaxAnalysis
-> ExtractTemplateDataFn
-> ExtractVariablesFn
-> FileType
-> FileSupport
FileSupport { fsSyntaxAnalysis :: SyntaxAnalysis
fsSyntaxAnalysis      = SyntaxAnalysis
syntaxAnalysis
                          , fsExtractTemplateData :: ExtractTemplateDataFn
fsExtractTemplateData = ExtractTemplateDataFn
extractTemplateData
                          , fsExtractVariables :: ExtractVariablesFn
fsExtractVariables    = ExtractVariablesFn
extractVariables
                          , fsFileType :: FileType
fsFileType            = FileType
Haskell
                          }


------------------------------  PRIVATE FUNCTIONS  -----------------------------

syntaxAnalysis :: SyntaxAnalysis
syntaxAnalysis :: SyntaxAnalysis
syntaxAnalysis = SyntaxAnalysis :: (Text -> Bool) -> (Text -> Bool) -> SyntaxAnalysis
SyntaxAnalysis
  { saIsCommentStart :: Text -> Bool
saIsCommentStart = Regex -> Text -> Bool
isMatch [re|^{-(?!\h*#)|^--|]
  , saIsCommentEnd :: Text -> Bool
saIsCommentEnd   = Regex -> Text -> Bool
isMatch [re|^\h*-}|\w+\h*-}|^--|]
  }


extractTemplateData :: Template a => a -> HeaderSyntax -> TemplateData
extractTemplateData :: a -> HeaderSyntax -> TemplateData
extractTemplateData a
template HeaderSyntax
syntax =
  let htdHaddockOffsets :: HaddockOffsets
htdHaddockOffsets = a -> HeaderSyntax -> HaddockOffsets
forall a. Template a => a -> HeaderSyntax -> HaddockOffsets
extractOffsets a
template HeaderSyntax
syntax
      templateData :: HaskellTemplateData'
templateData      = HaskellTemplateData' :: HaddockOffsets -> HaskellTemplateData'
HaskellTemplateData' { HaddockOffsets
htdHaddockOffsets :: HaddockOffsets
htdHaddockOffsets :: HaddockOffsets
.. }
  in  HaskellTemplateData' -> TemplateData
HaskellTemplateData HaskellTemplateData'
templateData


extractVariables :: HeaderTemplate
                 -> Maybe (Int, Int)
                 -> SourceCode
                 -> Variables
extractVariables :: ExtractVariablesFn
extractVariables HeaderTemplate {TemplateData
FileType
TemplateType
CtHeaderConfig
htTemplate :: HeaderTemplate -> TemplateType
htFileType :: HeaderTemplate -> FileType
htTemplateData :: HeaderTemplate -> TemplateData
htConfig :: HeaderTemplate -> CtHeaderConfig
htTemplate :: TemplateType
htFileType :: FileType
htTemplateData :: TemplateData
htConfig :: CtHeaderConfig
..} Maybe (Int, Int)
headerPos SourceCode
source =
  ([(Text, Text)] -> Variables
mkVariables ([(Text, Text)] -> Variables)
-> ([Maybe (Text, Text)] -> [(Text, Text)])
-> [Maybe (Text, Text)]
-> Variables
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Text, Text)] -> [(Text, Text)]
forall a. [Maybe a] -> [a]
catMaybes)
    [ (Text
"_haskell_module_copyright", ) (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
hmhCopyright
    , (Text
"_haskell_module_license", ) (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
hmhLicense
    , (Text
"_haskell_module_maintainer", ) (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
hmhMaintainer
    , (Text
"_haskell_module_name", ) (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceCode -> Maybe Text
extractModuleName SourceCode
source
    , (Text
"_haskell_module_portability", ) (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
hmhPortability
    , (Text
"_haskell_module_stability", ) (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
hmhStability
    , (Text
"_haskell_module_longdesc", ) (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
hmhLongDesc
    , (Text
"_haskell_module_shortdesc", ) (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
hmhShortDesc
    ]
 where
  HaddockModuleHeader {Maybe Text
hmhLongDesc :: HaddockModuleHeader -> Maybe Text
hmhShortDesc :: HaddockModuleHeader -> Maybe Text
hmhStability :: HaddockModuleHeader -> Maybe Text
hmhPortability :: HaddockModuleHeader -> Maybe Text
hmhMaintainer :: HaddockModuleHeader -> Maybe Text
hmhLicense :: HaddockModuleHeader -> Maybe Text
hmhCopyright :: HaddockModuleHeader -> Maybe Text
hmhShortDesc :: Maybe Text
hmhLongDesc :: Maybe Text
hmhStability :: Maybe Text
hmhPortability :: Maybe Text
hmhMaintainer :: Maybe Text
hmhLicense :: Maybe Text
hmhCopyright :: Maybe Text
..} = SourceCode -> TemplateData -> HeaderSyntax -> HaddockModuleHeader
extractModuleHeader SourceCode
header TemplateData
htTemplateData HeaderSyntax
syntax
  header :: SourceCode
header                   = SourceCode
-> ((Int, Int) -> SourceCode) -> Maybe (Int, Int) -> SourceCode
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SourceCode
forall a. Monoid a => a
mempty (\(Int
s, Int
e) -> Int -> Int -> SourceCode -> SourceCode
cut Int
s Int
e SourceCode
source) Maybe (Int, Int)
headerPos
  syntax :: 'Complete ::: HeaderSyntax
syntax                   = CtHeaderConfig -> 'Complete ::: HeaderSyntax
forall (p :: Phase). HeaderConfig p -> p ::: HeaderSyntax
hcHeaderSyntax CtHeaderConfig
htConfig


extractModuleName :: SourceCode -> Maybe Text
extractModuleName :: SourceCode -> Maybe Text
extractModuleName = ((Int, Text) -> Text) -> Maybe (Int, Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Text) -> Text
forall a b. (a, b) -> b
snd (Maybe (Int, Text) -> Maybe Text)
-> (SourceCode -> Maybe (Int, Text)) -> SourceCode -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CodeLine -> Maybe Text) -> SourceCode -> Maybe (Int, Text)
forall a. (CodeLine -> Maybe a) -> SourceCode -> Maybe (Int, a)
firstMatching CodeLine -> Maybe Text
f
 where
  f :: CodeLine -> Maybe Text
f (LineType
lt, Text
l) | LineType
lt LineType -> LineType -> Bool
forall a. Eq a => a -> a -> Bool
== LineType
Code = Regex -> Text -> Maybe [Text]
match [re|^module\s+(\S+)|] Text
l Maybe [Text] -> ([Text] -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Text] -> Getting (First Text) [Text] Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? Index [Text] -> Traversal' [Text] (IxValue [Text])
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index [Text]
1)
            | Bool
otherwise  = Maybe Text
forall a. Maybe a
Nothing