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

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

This module provides support for extracting /Haskell/-specific info from the
parsed /source code files/ as /template variables/. Such info includes
/module name/ and selected fields from /Haddock module header/
(see "Headroom.FileSupport.Haskell.Haddock").
-}

module Headroom.Ext.Haskell
  ( -- * Variables Extraction
    extractModuleName
  , extractVariables
    -- * Template Metadata Extraction
  , extractTemplateMeta
  )
where

import           Headroom.Configuration.Types   ( CtHeaderConfig )
import           Headroom.Data.Regex            ( match
                                                , re
                                                )
import           Headroom.Data.TextExtra        ( fromLines
                                                , toLines
                                                )
import           Headroom.Ext.Haskell.Haddock   ( HaddockModuleHeader(..)
                                                , extractFieldOffsets
                                                , extractModuleHeader
                                                )
import           Headroom.Template              ( Template(..) )
import           Headroom.Types                 ( TemplateMeta(..) )
import           Headroom.Variables             ( mkVariables )
import           Headroom.Variables.Types       ( Variables(..) )
import           RIO
import           RIO.Lens                       ( ix )
import qualified RIO.List                      as L


-- | Extracts name of /Haskell/ module from given source code file content.
--
-- >>> extractModuleName "{-# LANGUAGE OverloadedStrings #-}\nmodule Foo where"
-- Just "Foo"
extractModuleName :: Text
                  -- ^ input text
                  -> Maybe Text
                  -- ^ extracted module name
extractModuleName :: Text -> Maybe Text
extractModuleName = [Text] -> Maybe Text
go ([Text] -> Maybe Text) -> (Text -> [Text]) -> Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
toLines
 where
  go :: [Text] -> Maybe Text
go []       = Maybe Text
forall a. Maybe a
Nothing
  go (Text
x : [Text]
xs) = Maybe Text -> ([Text] -> Maybe Text) -> Maybe [Text] -> Maybe Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Text] -> Maybe Text
go [Text]
xs) ([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) (Regex -> Text -> Maybe [Text]
match [re|^module\s+(\S+)|] Text
x)


-- | Extracts variables from /Haskell/ source code.
--
-- __List of Extracted Variables:__
--
-- * @___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
extractVariables :: CtHeaderConfig
                 -- ^ license header configuration
                 -> Maybe TemplateMeta
                 -- ^ extracted metadata from corresponding /template/
                 -> Maybe (Int, Int)
                 -- ^ license header position @(startLine, endLine)@
                 -> Text
                 -- ^ input text
                 -> Variables
                 -- ^ extracted variables
extractVariables :: CtHeaderConfig
-> Maybe TemplateMeta -> Maybe (Int, Int) -> Text -> Variables
extractVariables CtHeaderConfig
_ Maybe TemplateMeta
meta Maybe (Int, Int)
headerPos Text
text = ([(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
<$> Text -> Maybe Text
extractModuleName Text
text
  , (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
..} = Text -> Maybe TemplateMeta -> HaddockModuleHeader
extractModuleHeader Text
headerText Maybe TemplateMeta
meta
  headerText :: Text
headerText               = Text -> ((Int, Int) -> Text) -> Maybe (Int, Int) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (\(Int
s, Int
e) -> Int -> Int -> Text -> Text
cut Int
s Int
e Text
text) Maybe (Int, Int)
headerPos
  cut :: Int -> Int -> Text -> Text
cut Int
s Int
e = [Text] -> Text
fromLines ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
L.take (Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
s) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
L.drop Int
s ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
toLines


-- | Extracts template metadata specific for /Haskell/.
extractTemplateMeta :: (Template t)
                    => t
                    -- ^ parsed /template/
                    -> TemplateMeta
                    -- ^ extracted template metadata
extractTemplateMeta :: t -> TemplateMeta
extractTemplateMeta t
template = HaddockFieldOffsets -> TemplateMeta
HaskellTemplateMeta HaddockFieldOffsets
offsets
  where offsets :: HaddockFieldOffsets
offsets = t -> HaddockFieldOffsets
forall t. Template t => t -> HaddockFieldOffsets
extractFieldOffsets t
template