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

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

import Data.Char
import Data.List
import Data.List.Split
import Data.Maybe
import qualified Data.Text as T
import qualified GHC.Driver.Session as GLP
import qualified GHC.LanguageExtensions 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 :: [T.Text] -> [Extension]
getExtensions :: [Text] -> [Extension]
getExtensions = (Text -> [Extension] -> [Extension])
-> [Extension] -> [Text] -> [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 (String -> [Extension] -> [Extension])
-> (Text -> String) -> Text -> [Extension] -> [Extension]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) [Extension]
defaultExtensions
  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

-- | Default extensions.
defaultExtensions :: [Extension]
defaultExtensions :: [Extension]
defaultExtensions = (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]) -> [Extension] -> [Extension]
forall a b. (a -> b) -> a -> b
$ [Extension
forall a. Bounded a => a
minBound ..] [Extension] -> [Extension] -> [Extension]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Extension]
badExtensions

-- | All extensions supported by Cabal.
allExtensions :: [Extension]
allExtensions :: [Extension]
allExtensions = (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
forall a. Bounded a => a
minBound ..]

-- | Extensions which steal too much syntax.
badExtensions :: [GLP.Extension]
badExtensions :: [Extension]
badExtensions =
  [ Extension
GLP.Arrows -- steals proc
  , Extension
GLP.TransformListComp -- steals the group keyword
  , Extension
GLP.UnboxedTuples -- breaks (#) lens operator
  , Extension
GLP.UnboxedSums -- Same as 'UnboxedTuples'
    -- ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break
  , Extension
GLP.PatternSynonyms -- steals the pattern keyword
  , Extension
GLP.RecursiveDo -- steals the rec keyword
  , Extension
GLP.TypeApplications -- Steals `@`
  , Extension
GLP.StaticPointers -- Steals the `static` keyword
  , Extension
GLP.AlternativeLayoutRule -- Breaks a few tests
  , Extension
GLP.AlternativeLayoutRuleTransitional -- Same as `AlternativeLayoutRule`
  , Extension
GLP.LexicalNegation -- Cannot handle minus signs in some cases
  , Extension
GLP.OverloadedRecordDot -- Breaks 'a.b'
  , Extension
GLP.OverloadedRecordUpdate -- Cannot handle symbol members starting
                               -- with a dot in a record well
  ]