{-# 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 _ (Just (ModuleHead _ mn :: ModuleName l
mn _ _)) _ _ _) = ModuleName l
mn
getModuleName (XmlPage _ mn :: ModuleName l
mn _ _ _ _ _) = ModuleName l
mn
getModuleName (XmlHybrid _ (Just (ModuleHead _ mn :: ModuleName l
mn _ _)) _ _ _ _ _ _ _) = ModuleName l
mn
getModuleName m :: 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 _ _ _ is :: [ImportDecl l]
is _) = [ImportDecl l]
is
getImports (XmlPage _ _ _ _ _ _ _) = []
getImports (XmlHybrid _ _ _ is :: [ImportDecl l]
is _ _ _ _ _) = [ImportDecl l]
is

getModuleDecls :: Module l -> [Decl l]
getModuleDecls :: Module l -> [Decl l]
getModuleDecls (Module _ _ _ _ ds :: [Decl l]
ds) = [Decl l]
ds
getModuleDecls (XmlPage _ _ _ _ _ _ _) = []
getModuleDecls (XmlHybrid _ _ _ _ ds :: [Decl l]
ds _ _ _ _) = [Decl l]
ds

getExportSpecList :: Module l -> Maybe (ExportSpecList l)
getExportSpecList :: Module l -> Maybe (ExportSpecList l)
getExportSpecList m :: Module l
m = Maybe (ExportSpecList l)
me where ModuleHead _ _ _ me :: 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 _ (Just mh :: ModuleHead l
mh) _ _ _) = ModuleHead l
mh
getModuleHead (XmlHybrid _ (Just mh :: ModuleHead l
mh) _ _ _ _ _ _ _) = ModuleHead l
mh
getModuleHead m :: 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 "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 _ n :: Name l
n) = Name l
n
qNameToName (Qual _ _ n :: Name l
n) = Name l
n
qNameToName (Special l :: l
l s :: 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 dh :: DeclHead l
dh =
  case DeclHead l
dh of
    DHead _ n :: Name l
n -> Name l
n
    DHInfix _ _ n :: Name l
n -> Name l
n
    DHParen _ dh' :: DeclHead l
dh' -> DeclHead l -> Name l
forall l. DeclHead l -> Name l
getDeclHeadName DeclHead l
dh'
    DHApp _ dh' :: DeclHead l
dh' _ -> DeclHead l -> Name l
forall l. DeclHead l -> Name l
getDeclHeadName DeclHead l
dh'

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

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

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

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

unCName :: CName l -> Name l
unCName :: CName l -> Name l
unCName (VarName _ n :: Name l
n) = Name l
n
unCName (ConName _ n :: 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 errors :: Set (Error l)
errors (Scoped (ScopeError e :: Error l
e) _) = 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 errors :: Set (Error l)
errors _ = 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 globalLang :: Language
globalLang globalExts :: [Extension]
globalExts mod :: Module l
mod =
  let
    (mbModLang :: Maybe Language
mbModLang, modExts :: [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 mod :: Module l
mod =
  let
    names :: [String]
names =
      [ String
name
      | let
          pragmas :: [ModulePragma l]
pragmas =
            case Module l
mod of
              Module _ _ pragmas :: [ModulePragma l]
pragmas _ _ -> [ModulePragma l]
pragmas
              XmlPage _ _ pragmas :: [ModulePragma l]
pragmas _ _ _ _ -> [ModulePragma l]
pragmas
              XmlHybrid _ _ pragmas :: [ModulePragma l]
pragmas _ _ _ _ _ _ -> [ModulePragma l]
pragmas
      , LanguagePragma _ names :: [Name l]
names <- [ModulePragma l]
pragmas
      , Ident _ name :: 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
$ \name :: String
name ->
        case (String -> Extension
parseExtension String
name, String -> Language
classifyLanguage String
name) of
          (e :: Extension
e, UnknownLanguage {}) -> Extension -> Either Language Extension
forall a b. b -> Either a b
Right Extension
e
          (_, l :: Language
l) -> Language -> Either Language Extension
forall a b. a -> Either a b
Left Language
l

    (langs :: [Language]
langs, exts :: [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)