module Language.Haskell.Exts.Extension (
Language(..),
knownLanguages,
classifyLanguage,
prettyLanguage,
Extension(..), KnownExtension(..),
classifyExtension,
parseExtension, prettyExtension,
ghcDefault, glasgowExts,
knownExtensions, deprecatedExtensions,
impliesExts, toExtensionList
) where
import Control.Applicative ((<$>), (<|>))
import Data.Array (Array, accumArray, bounds, Ix(inRange), (!))
import Data.List (nub, (\\), delete)
import Data.Maybe (fromMaybe)
data Language =
Haskell98
| Haskell2010
| HaskellAllDisabled
| UnknownLanguage String
deriving (Show, Read, Eq, Ord)
knownLanguages :: [Language]
knownLanguages = [Haskell98, Haskell2010]
classifyLanguage :: String -> Language
classifyLanguage = \str -> case lookup str langTable of
Just lang -> lang
Nothing -> UnknownLanguage str
where
langTable = [ (show lang, lang)
| lang <- knownLanguages ]
prettyLanguage :: Language -> String
prettyLanguage (UnknownLanguage name) = name
prettyLanguage lang = show lang
data Extension =
EnableExtension KnownExtension
| DisableExtension KnownExtension
| UnknownExtension String
deriving (Show, Read, Eq, Ord)
data KnownExtension =
OverlappingInstances
| UndecidableInstances
| IncoherentInstances
| RecursiveDo
| ParallelListComp
| MultiParamTypeClasses
| MonomorphismRestriction
| FunctionalDependencies
| Rank2Types
| RankNTypes
| PolymorphicComponents
| ExistentialQuantification
| ScopedTypeVariables
| PatternSignatures
| ImplicitParams
| FlexibleContexts
| FlexibleInstances
| EmptyDataDecls
| CPP
| KindSignatures
| BangPatterns
| TypeSynonymInstances
| TemplateHaskell
| ForeignFunctionInterface
| Arrows
| Generics
| ImplicitPrelude
| NamedFieldPuns
| PatternGuards
| GeneralizedNewtypeDeriving
| ExtensibleRecords
| RestrictedTypeSynonyms
| HereDocuments
| MagicHash
| TypeFamilies
| StandaloneDeriving
| UnicodeSyntax
| UnliftedFFITypes
| LiberalTypeSynonyms
| TypeOperators
| RecordWildCards
| RecordPuns
| DisambiguateRecordFields
| OverloadedStrings
| GADTs
| MonoPatBinds
| RelaxedPolyRec
| ExtendedDefaultRules
| UnboxedTuples
| DeriveDataTypeable
| ConstrainedClassMethods
| PackageImports
| ImpredicativeTypes
| NewQualifiedOperators
| PostfixOperators
| QuasiQuotes
| TransformListComp
| ViewPatterns
| XmlSyntax
| RegularPatterns
| TupleSections
| GHCForeignImportPrim
| NPlusKPatterns
| DoAndIfThenElse
| RebindableSyntax
| ExplicitForAll
| DatatypeContexts
| MonoLocalBinds
| DeriveFunctor
| DeriveTraversable
| DeriveFoldable
| NondecreasingIndentation
| InterruptibleFFI
| CApiFFI
deriving (Show, Read, Eq, Ord, Enum, Bounded)
impliesExts :: [KnownExtension] -> [KnownExtension]
impliesExts = go
where go [] = []
go es = let xs = concatMap implE es
ys = filter (not . flip elem es) xs
in es ++ go ys
implE e = case e of
TypeFamilies -> [KindSignatures]
ScopedTypeVariables -> [TypeOperators, ExplicitForAll]
XmlSyntax -> [RegularPatterns]
RegularPatterns -> [PatternGuards]
RankNTypes -> [Rank2Types, ExplicitForAll]
Rank2Types -> [PolymorphicComponents, ExplicitForAll]
PolymorphicComponents -> [ExplicitForAll]
LiberalTypeSynonyms -> [ExplicitForAll]
ExistentialQuantification -> [ExplicitForAll]
RecordPuns -> [NamedFieldPuns]
PatternSignatures -> [ScopedTypeVariables]
e -> []
glasgowExts :: [Extension]
glasgowExts = map EnableExtension [
ForeignFunctionInterface
, UnliftedFFITypes
, GADTs
, ImplicitParams
, ScopedTypeVariables
, UnboxedTuples
, TypeSynonymInstances
, StandaloneDeriving
, DeriveDataTypeable
, FlexibleContexts
, FlexibleInstances
, ConstrainedClassMethods
, MultiParamTypeClasses
, FunctionalDependencies
, MagicHash
, PolymorphicComponents
, ExistentialQuantification
, UnicodeSyntax
, PostfixOperators
, PatternGuards
, LiberalTypeSynonyms
, RankNTypes
, ImpredicativeTypes
, TypeOperators
, RecursiveDo
, ParallelListComp
, EmptyDataDecls
, KindSignatures
, GeneralizedNewtypeDeriving
, TypeFamilies
]
allLangDefault :: [KnownExtension]
allLangDefault = [MonomorphismRestriction, MonoPatBinds, ImplicitPrelude]
ghcDefault :: [Extension]
ghcDefault = map EnableExtension (NondecreasingIndentation:allLangDefault)
knownExtensions :: [Extension]
knownExtensions =
concat [ [EnableExtension x, DisableExtension x] | x <- [minBound..maxBound] ]
deprecatedExtensions :: [(Extension, Maybe Extension)]
deprecatedExtensions =
[ (EnableExtension RecordPuns, Just (EnableExtension NamedFieldPuns))
, (EnableExtension PatternSignatures, Just (EnableExtension ScopedTypeVariables))
]
classifyExtension :: String -> Extension
classifyExtension string
= case classifyKnownExtension string of
Just ext -> EnableExtension ext
Nothing ->
case string of
'N':'o':string' ->
case classifyKnownExtension string' of
Just ext -> DisableExtension ext
Nothing -> UnknownExtension string
_ -> UnknownExtension string
classifyKnownExtension :: String -> Maybe KnownExtension
classifyKnownExtension "" = Nothing
classifyKnownExtension string@(c : _)
| inRange (bounds knownExtensionTable) c
= lookup string (knownExtensionTable ! c)
| otherwise = Nothing
knownExtensionTable :: Array Char [(String, KnownExtension)]
knownExtensionTable =
accumArray (flip (:)) [] ('A', 'Z')
[ (head str, (str, extension))
| extension <- [toEnum 0 ..]
, let str = show extension ]
parseExtension :: String -> Extension
parseExtension str = fromMaybe (UnknownExtension str) $
EnableExtension <$> readMay str
<|> DisableExtension <$> (readMay =<< dropNo str)
where
dropNo ('N':'o':rest) = Just rest
dropNo _ = Nothing
prettyExtension :: Extension -> String
prettyExtension (EnableExtension ext) = show ext
prettyExtension (DisableExtension ext) = "No" ++ show ext
prettyExtension (UnknownExtension str) = str
readMay :: Read a => String -> Maybe a
readMay s = case [x | (x,t) <- reads s, ("","") <- lex t] of
[x] -> Just x
_ -> Nothing
toExtensionList :: Language -> [Extension] -> [KnownExtension]
toExtensionList lang exts =
let langKes = case lang of
Haskell98 -> NPlusKPatterns:allLangDefault
Haskell2010 -> [DoAndIfThenElse
, PatternGuards
, ForeignFunctionInterface
, EmptyDataDecls
] ++ allLangDefault
HaskellAllDisabled -> []
UnknownLanguage s ->
error $ "toExtensionList: Unknown language " ++ s
in impliesExts $ go langKes exts
where go :: [KnownExtension] -> [Extension] -> [KnownExtension]
go acc [] = acc
go acc (DisableExtension x : exts) = go (nub (delete x acc)) exts
go acc (EnableExtension x : exts) = go (nub (x : acc)) exts
go acc (_ : exts) = go acc exts