{-# OPTIONS -fno-warn-name-shadowing #-}
module Language.Haskell.Names.SyntaxUtils
  ( dropAnn
  , getModuleName
  , getImports
  , getExportSpecList
  , getDeclHeadName
  , getModuleDecls
  , nameToString
  , stringToName
  , qNameToName
  , unCName
  , getErrors
  , moduleExtensions
  ) where

import           Language.Haskell.Names.Types

import           Data.Char
import           Data.Either
import           Data.Foldable
import           Data.Maybe
import qualified Data.Set                        as Set
import           Language.Haskell.Exts

dropAnn :: (Functor a) => a l -> a ()
dropAnn :: a l -> a ()
dropAnn = (l -> ()) -> a l -> a ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> l -> ()
forall a b. a -> b -> a
const ())

getModuleName :: Module l -> ModuleName l
getModuleName :: Module l -> ModuleName l
getModuleName (Module l
_ (Just (ModuleHead l
_ ModuleName l
mn Maybe (WarningText l)
_ Maybe (ExportSpecList l)
_)) [ModulePragma l]
_ [ImportDecl l]
_ [Decl l]
_) = ModuleName l
mn
getModuleName (XmlPage l
_ ModuleName l
mn [ModulePragma l]
_ XName l
_ [XAttr l]
_ Maybe (Exp l)
_ [Exp l]
_) = ModuleName l
mn
getModuleName (XmlHybrid l
_ (Just (ModuleHead l
_ ModuleName l
mn Maybe (WarningText l)
_ Maybe (ExportSpecList l)
_)) [ModulePragma l]
_ [ImportDecl l]
_ [Decl l]
_ XName l
_ [XAttr l]
_ Maybe (Exp l)
_ [Exp l]
_) = ModuleName l
mn
getModuleName Module l
m = l -> ModuleName l
forall l. l -> ModuleName l
main_mod (Module l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Module l
m)

getImports :: Module l -> [ImportDecl l]
getImports :: Module l -> [ImportDecl l]
getImports (Module l
_ Maybe (ModuleHead l)
_ [ModulePragma l]
_ [ImportDecl l]
is [Decl l]
_) = [ImportDecl l]
is
getImports (XmlPage l
_ ModuleName l
_ [ModulePragma l]
_ XName l
_ [XAttr l]
_ Maybe (Exp l)
_ [Exp l]
_) = []
getImports (XmlHybrid l
_ Maybe (ModuleHead l)
_ [ModulePragma l]
_ [ImportDecl l]
is [Decl l]
_ XName l
_ [XAttr l]
_ Maybe (Exp l)
_ [Exp l]
_) = [ImportDecl l]
is

getModuleDecls :: Module l -> [Decl l]
getModuleDecls :: Module l -> [Decl l]
getModuleDecls (Module l
_ Maybe (ModuleHead l)
_ [ModulePragma l]
_ [ImportDecl l]
_ [Decl l]
ds) = [Decl l]
ds
getModuleDecls (XmlPage l
_ ModuleName l
_ [ModulePragma l]
_ XName l
_ [XAttr l]
_ Maybe (Exp l)
_ [Exp l]
_) = []
getModuleDecls (XmlHybrid l
_ Maybe (ModuleHead l)
_ [ModulePragma l]
_ [ImportDecl l]
_ [Decl l]
ds XName l
_ [XAttr l]
_ Maybe (Exp l)
_ [Exp l]
_) = [Decl l]
ds

getExportSpecList :: Module l -> Maybe (ExportSpecList l)
getExportSpecList :: Module l -> Maybe (ExportSpecList l)
getExportSpecList Module l
m = Maybe (ExportSpecList l)
me where ModuleHead l
_ ModuleName l
_ Maybe (WarningText l)
_ Maybe (ExportSpecList l)
me = Module l -> ModuleHead l
forall l. Module l -> ModuleHead l
getModuleHead Module l
m

getModuleHead :: Module l -> ModuleHead l
getModuleHead :: Module l -> ModuleHead l
getModuleHead (Module l
_ (Just ModuleHead l
mh) [ModulePragma l]
_ [ImportDecl l]
_ [Decl l]
_) = ModuleHead l
mh
getModuleHead (XmlHybrid l
_ (Just ModuleHead l
mh) [ModulePragma l]
_ [ImportDecl l]
_ [Decl l]
_ XName l
_ [XAttr l]
_ Maybe (Exp l)
_ [Exp l]
_) = ModuleHead l
mh
getModuleHead Module l
m = l
-> ModuleName l
-> Maybe (WarningText l)
-> Maybe (ExportSpecList l)
-> ModuleHead l
forall l.
l
-> ModuleName l
-> Maybe (WarningText l)
-> Maybe (ExportSpecList l)
-> ModuleHead l
ModuleHead l
l (l -> ModuleName l
forall l. l -> ModuleName l
main_mod l
l) Maybe (WarningText l)
forall a. Maybe a
Nothing (ExportSpecList l -> Maybe (ExportSpecList l)
forall a. a -> Maybe a
Just (l -> [ExportSpec l] -> ExportSpecList l
forall l. l -> [ExportSpec l] -> ExportSpecList l
ExportSpecList l
l [l -> QName l -> ExportSpec l
forall l. l -> QName l -> ExportSpec l
EVar l
l (l -> Name l -> QName l
forall l. l -> Name l -> QName l
UnQual l
l (l -> String -> Name l
forall l. l -> String -> Name l
Ident l
l String
"main"))]))
  where l :: l
l = Module l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Module l
m

qNameToName :: QName l -> Name l
qNameToName :: QName l -> Name l
qNameToName (UnQual l
_ Name l
n) = Name l
n
qNameToName (Qual l
_ ModuleName l
_ Name l
n) = Name l
n
qNameToName (Special l
l SpecialCon l
s) = l -> String -> Name l
forall l. l -> String -> Name l
Ident l
l (SpecialCon l -> String
forall l. SpecialCon l -> String
specialConToString SpecialCon l
s)

getDeclHeadName :: DeclHead l -> Name l
getDeclHeadName :: DeclHead l -> Name l
getDeclHeadName DeclHead l
dh =
  case DeclHead l
dh of
    DHead l
_ Name l
n -> Name l
n
    DHInfix l
_ TyVarBind l
_ Name l
n -> Name l
n
    DHParen l
_ DeclHead l
dh' -> DeclHead l -> Name l
forall l. DeclHead l -> Name l
getDeclHeadName DeclHead l
dh'
    DHApp l
_ DeclHead l
dh' TyVarBind l
_ -> DeclHead l -> Name l
forall l. DeclHead l -> Name l
getDeclHeadName DeclHead l
dh'

----------------------------------------------------

nameToString :: Name l -> String
nameToString :: Name l -> String
nameToString (Ident l
_ String
s) = String
s
nameToString (Symbol l
_ String
s) = String
s

stringToName :: String -> Name ()
stringToName :: String -> Name ()
stringToName s :: String
s@(Char
c:String
_) | Char -> Bool
isSymbol Char
c = () -> String -> Name ()
forall l. l -> String -> Name l
Symbol () String
s
stringToName String
s = () -> String -> Name ()
forall l. l -> String -> Name l
Ident () String
s

specialConToString :: SpecialCon l -> String
specialConToString :: SpecialCon l -> String
specialConToString (UnitCon l
_)            = String
"()"
specialConToString (ListCon l
_)            = String
"[]"
specialConToString (FunCon l
_)             = String
"->"
specialConToString (TupleCon l
_ Boxed
Boxed Int
n)   = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Char
','
specialConToString (TupleCon l
_ Boxed
Unboxed Int
n) = Char
'#'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Char
','
specialConToString (Cons l
_)               = String
":"
specialConToString (UnboxedSingleCon l
_)   = String
"#"
specialConToString (ExprHole l
_)           = String
"_"

unCName :: CName l -> Name l
unCName :: CName l -> Name l
unCName (VarName l
_ Name l
n) = Name l
n
unCName (ConName l
_ Name l
n) = Name l
n

getErrors :: (Ord l, Foldable a) => a (Scoped l) -> Set.Set (Error l)
getErrors :: a (Scoped l) -> Set (Error l)
getErrors = (Set (Error l) -> Scoped l -> Set (Error l))
-> Set (Error l) -> a (Scoped l) -> Set (Error l)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set (Error l) -> Scoped l -> Set (Error l)
forall l. Ord l => Set (Error l) -> Scoped l -> Set (Error l)
f Set (Error l)
forall a. Set a
Set.empty
  where
    f :: Set (Error l) -> Scoped l -> Set (Error l)
f Set (Error l)
errors (Scoped (ScopeError Error l
e) l
_) = Error l -> Set (Error l) -> Set (Error l)
forall a. Ord a => a -> Set a -> Set a
Set.insert Error l
e Set (Error l)
errors
    f Set (Error l)
errors Scoped l
_ = Set (Error l)
errors

-- | Compute the extension set for the given module, based on the global
-- preferences (e.g. specified on the command line) and module's LANGUAGE
-- pragmas.
moduleExtensions
  :: Language    -- ^ base language
  -> [Extension] -- ^ global extensions
  -> Module l
  -> ExtensionSet
moduleExtensions :: Language -> [Extension] -> Module l -> ExtensionSet
moduleExtensions Language
globalLang [Extension]
globalExts Module l
mod =
  let
    (Maybe Language
mbModLang, [Extension]
modExts) = Module l -> (Maybe Language, [Extension])
forall l. Module l -> (Maybe Language, [Extension])
getModuleExtensions Module l
mod
    lang :: Language
lang = Language -> Maybe Language -> Language
forall a. a -> Maybe a -> a
fromMaybe Language
globalLang Maybe Language
mbModLang
    kexts :: [KnownExtension]
kexts = Language -> [Extension] -> [KnownExtension]
toExtensionList Language
lang ([Extension]
globalExts [Extension] -> [Extension] -> [Extension]
forall a. [a] -> [a] -> [a]
++ [Extension]
modExts)
  in [KnownExtension] -> ExtensionSet
forall a. Ord a => [a] -> Set a
Set.fromList [KnownExtension]
kexts

getModuleExtensions :: Module l -> (Maybe Language, [Extension])
getModuleExtensions :: Module l -> (Maybe Language, [Extension])
getModuleExtensions Module l
mod =
  let
    names :: [String]
names =
      [ String
name
      | let
          pragmas :: [ModulePragma l]
pragmas =
            case Module l
mod of
              Module l
_ Maybe (ModuleHead l)
_ [ModulePragma l]
pragmas [ImportDecl l]
_ [Decl l]
_ -> [ModulePragma l]
pragmas
              XmlPage l
_ ModuleName l
_ [ModulePragma l]
pragmas XName l
_ [XAttr l]
_ Maybe (Exp l)
_ [Exp l]
_ -> [ModulePragma l]
pragmas
              XmlHybrid l
_ Maybe (ModuleHead l)
_ [ModulePragma l]
pragmas [ImportDecl l]
_ [Decl l]
_ XName l
_ [XAttr l]
_ Maybe (Exp l)
_ [Exp l]
_ -> [ModulePragma l]
pragmas
      , LanguagePragma l
_ [Name l]
names <- [ModulePragma l]
pragmas
      , Ident l
_ String
name <- [Name l]
names
      ]

    classified :: [Either Language Extension]
    classified :: [Either Language Extension]
classified =
      ((String -> Either Language Extension)
 -> [String] -> [Either Language Extension])
-> [String]
-> (String -> Either Language Extension)
-> [Either Language Extension]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String -> Either Language Extension)
-> [String] -> [Either Language Extension]
forall a b. (a -> b) -> [a] -> [b]
map [String]
names ((String -> Either Language Extension)
 -> [Either Language Extension])
-> (String -> Either Language Extension)
-> [Either Language Extension]
forall a b. (a -> b) -> a -> b
$ \String
name ->
        case (String -> Extension
parseExtension String
name, String -> Language
classifyLanguage String
name) of
          (Extension
e, UnknownLanguage {}) -> Extension -> Either Language Extension
forall a b. b -> Either a b
Right Extension
e
          (Extension
_, Language
l) -> Language -> Either Language Extension
forall a b. a -> Either a b
Left Language
l

    ([Language]
langs, [Extension]
exts) = [Either Language Extension] -> ([Language], [Extension])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Language Extension]
classified
  in
    (if [Language] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Language]
langs then Maybe Language
forall a. Maybe a
Nothing else Language -> Maybe Language
forall a. a -> Maybe a
Just (Language -> Maybe Language) -> Language -> Maybe Language
forall a b. (a -> b) -> a -> b
$ [Language] -> Language
forall a. [a] -> a
last [Language]
langs, [Extension]
exts)