{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Operations related to language extensions.
module HIndent.LanguageExtension
  ( implicitExtensions
  , extensionImplies
  , collectLanguageExtensionsFromSource
  , getExtensions
  ) where

import Data.Char
import Data.List
import Data.List.Split
import Data.Maybe
import qualified GHC.Driver.Session as GLP
import HIndent.LanguageExtension.Conversion
import HIndent.LanguageExtension.Types
import HIndent.Pragma
import Text.Regex.TDFA

-- | This function returns a list of extensions that the passed language
-- (e.g., GHC2021) enables.
implicitExtensions :: GLP.Language -> [Extension]
implicitExtensions :: Language -> [Extension]
implicitExtensions = (Extension -> Extension) -> [Extension] -> [Extension]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Extension -> Extension
EnableExtension ([Extension] -> [Extension])
-> (Language -> [Extension]) -> Language -> [Extension]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Language -> [Extension]
GLP.languageExtensions (Maybe Language -> [Extension])
-> (Language -> Maybe Language) -> Language -> [Extension]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Language -> Maybe Language
forall a. a -> Maybe a
Just

-- | This function returns a list of extensions that the passed extension
-- enables and disables.
--
-- For example, @GADTs@ enables @GADTSyntax@ and @RebindableSyntax@
-- disables @ImplicitPrelude@.
extensionImplies :: Extension -> [Extension]
extensionImplies :: Extension -> [Extension]
extensionImplies (EnableExtension Extension
e) =
  (Extension, Bool, Extension) -> Extension
forall {a}. (a, Bool, Extension) -> Extension
toExtension ((Extension, Bool, Extension) -> Extension)
-> [(Extension, Bool, Extension)] -> [Extension]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Extension, Bool, Extension) -> Bool)
-> [(Extension, Bool, Extension)] -> [(Extension, Bool, Extension)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Extension
a, Bool
_, Extension
_) -> Extension
e Extension -> Extension -> Bool
forall a. Eq a => a -> a -> Bool
== Extension
a) [(Extension, Bool, Extension)]
GLP.impliedXFlags
  where
    toExtension :: (a, Bool, Extension) -> Extension
toExtension (a
_, Bool
True, Extension
e') = Extension -> Extension
EnableExtension Extension
e'
    toExtension (a
_, Bool
False, Extension
e') = Extension -> Extension
DisableExtension Extension
e'
extensionImplies Extension
_ = []

-- | Collect pragmas specified in the source code.
collectLanguageExtensionsFromSource :: String -> [Extension]
collectLanguageExtensionsFromSource :: String -> [Extension]
collectLanguageExtensionsFromSource =
  [Extension] -> [Extension] -> [Extension]
forall a. [a] -> [a] -> [a]
(++)
    ([Extension] -> [Extension] -> [Extension])
-> (String -> [Extension]) -> String -> [Extension] -> [Extension]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [Extension]
collectLanguageExtensionsSpecifiedViaLanguagePragma
    (String -> [Extension] -> [Extension])
-> (String -> [Extension]) -> String -> [Extension]
forall a b. (String -> a -> b) -> (String -> a) -> String -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> [Extension]
collectLanguageExtensionsFromSourceViaOptionsPragma

-- | Consume an extensions list from arguments.
getExtensions :: [String] -> [Extension]
getExtensions :: [String] -> [Extension]
getExtensions = (String -> [Extension] -> [Extension])
-> [Extension] -> [String] -> [Extension]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> [Extension] -> [Extension]
f []
  where
    f :: String -> [Extension] -> [Extension]
f String
"Haskell98" [Extension]
_ = []
    f String
x [Extension]
a =
      case String -> Maybe Extension
strToExt String
x of
        Just x' :: Extension
x'@EnableExtension {} -> Extension
x' Extension -> [Extension] -> [Extension]
forall a. a -> [a] -> [a]
: Extension -> [Extension] -> [Extension]
forall a. Eq a => a -> [a] -> [a]
delete Extension
x' [Extension]
a
        Just (DisableExtension Extension
x') -> Extension -> [Extension] -> [Extension]
forall a. Eq a => a -> [a] -> [a]
delete (Extension -> Extension
EnableExtension Extension
x') [Extension]
a
        Maybe Extension
_ -> String -> [Extension]
forall a. HasCallStack => String -> a
error (String -> [Extension]) -> String -> [Extension]
forall a b. (a -> b) -> a -> b
$ String
"Unknown extension: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x

-- | Collects language extensions enabled or disabled by @{-# LANGUAGE FOO
-- #-}@.
--
-- This function ignores language extensions not supported by Cabal.
collectLanguageExtensionsSpecifiedViaLanguagePragma :: String -> [Extension]
collectLanguageExtensionsSpecifiedViaLanguagePragma :: String -> [Extension]
collectLanguageExtensionsSpecifiedViaLanguagePragma =
  (String -> Maybe Extension) -> [String] -> [Extension]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> Maybe Extension
strToExt (String -> Maybe Extension)
-> (String -> String) -> String -> Maybe Extension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
stripSpaces)
    ([String] -> [Extension])
-> (String -> [String]) -> String -> [Extension]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
",")
    ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, String) -> String
forall a b. (a, b) -> b
snd
    ([(String, String)] -> [String])
-> (String -> [(String, String)]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"LANGUAGE") (String -> Bool)
-> ((String, String) -> String) -> (String, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst)
    ([(String, String)] -> [(String, String)])
-> (String -> [(String, String)]) -> String -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(String, String)]
extractPragmasFromCode

-- | Extracts the language extensions specified by @-XFOO@ from @OPTIONS@
-- or @OPTIONS_GHC@ pragmas
collectLanguageExtensionsFromSourceViaOptionsPragma :: String -> [Extension]
collectLanguageExtensionsFromSourceViaOptionsPragma :: String -> [Extension]
collectLanguageExtensionsFromSourceViaOptionsPragma =
  (String -> Maybe Extension) -> [String] -> [Extension]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> Maybe Extension
strToExt (String -> Maybe Extension)
-> (String -> String) -> String -> Maybe Extension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
stripSpaces)
    ([String] -> [Extension])
-> (String -> [String]) -> String -> [Extension]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [String]
extractLanguageExtensionsFromOptions
    ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, String) -> String
forall a b. (a, b) -> b
snd
    ([(String, String)] -> [String])
-> (String -> [(String, String)]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"OPTIONS", String
"OPTIONS_GHC"]) (String -> Bool)
-> ((String, String) -> String) -> (String, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst)
    ([(String, String)] -> [(String, String)])
-> (String -> [(String, String)]) -> String -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(String, String)]
extractPragmasFromCode

-- | Extracts the language extensions specified in the '-XFOO' format from
-- the given string
extractLanguageExtensionsFromOptions :: String -> [String]
extractLanguageExtensionsFromOptions :: String -> [String]
extractLanguageExtensionsFromOptions String
options =
  (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    String -> String
trimXOption
    (AllTextMatches [] String -> [String]
forall (f :: * -> *) b. AllTextMatches f b -> f b
getAllTextMatches (String
options String -> String -> AllTextMatches [] String
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ String
"-X[^,[:space:]]+") :: [String])
  where
    trimXOption :: String -> String
trimXOption (Char
'-':Char
'X':String
xs) = String
xs
    trimXOption String
_ = String -> String
forall a. HasCallStack => String -> a
error String
"Unreachable: the option must have the `-X` prefix."

-- | Removes spaces before and after the string.
stripSpaces :: String -> String
stripSpaces :: String -> String
stripSpaces = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace