module Language.Haskell.Names.SyntaxUtils
  ( dropAnn
  , setAnn
  , annName
  , nameQualification
  , getModuleName
  , getImports
  , getExportSpecList
  , getDeclHead
  , getDeclHeadName
  , getModuleDecls
  , isTypeDecl
  , opName
  , isCon
  , nameToString
  , stringToName
  , specialConToString
  , qNameToName
  , nameToQName
  , unCName
  , getErrors
  , getModuleExtensions
  ) where
import Prelude hiding (concatMap)
import Data.Char
import Data.Either
import Data.Foldable hiding (elem)
import qualified Data.Set as Set
import Language.Haskell.Exts
import Language.Haskell.Names.Types

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

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

annName :: a -> a
annName :: forall a. a -> a
annName = a -> a
forall a. a -> a
id

nameQualification :: QName l -> Maybe (ModuleName ())
nameQualification :: forall l. QName l -> Maybe (ModuleName ())
nameQualification (UnQual l
_ Name l
_) =
  Maybe (ModuleName ())
forall a. Maybe a
Nothing
nameQualification (Special l
_ SpecialCon l
_) =
  Maybe (ModuleName ())
forall a. Maybe a
Nothing
nameQualification (Qual l
_ (ModuleName l
_ String
moduleName) Name l
_) =
  ModuleName () -> Maybe (ModuleName ())
forall a. a -> Maybe a
Just (() -> String -> ModuleName ()
forall l. l -> String -> ModuleName l
ModuleName () String
moduleName)

getModuleName :: Module l -> ModuleName l
getModuleName :: forall l. 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 l. Module l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Module l
m)

getImports :: Module l -> [ImportDecl l]
getImports :: forall l. 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 :: forall l. 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 :: forall l. 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 :: forall l. 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 l. Module l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Module l
m

qNameToName :: QName l -> Name l
qNameToName :: forall l. 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)

nameToQName :: Name l -> QName l
nameToQName :: forall l. Name l -> QName l
nameToQName Name l
n = l -> Name l -> QName l
forall l. l -> Name l -> QName l
UnQual (Name l -> l
forall l. Name l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Name l
n) Name l
n

{-
getImportDecls :: Module l -> [ImportDecl l]
getImportDecls (Module _ _ _ is _) = is
getImportDecls (XmlPage _ _ _ _ _ _ _) = []
getImportDecls (XmlHybrid _ _ _ is _ _ _ _ _) = is
-}

getDeclHead :: Decl l -> Maybe (DeclHead l)
getDeclHead :: forall l. Decl l -> Maybe (DeclHead l)
getDeclHead (TypeDecl l
_ DeclHead l
dhead Type l
_) = DeclHead l -> Maybe (DeclHead l)
forall a. a -> Maybe a
Just DeclHead l
dhead
getDeclHead (TypeFamDecl l
_ DeclHead l
dhead Maybe (ResultSig l)
_ Maybe (InjectivityInfo l)
_) = DeclHead l -> Maybe (DeclHead l)
forall a. a -> Maybe a
Just DeclHead l
dhead
getDeclHead (DataDecl l
_ DataOrNew l
_ Maybe (Context l)
_ DeclHead l
dhead [QualConDecl l]
_ [Deriving l]
_) = DeclHead l -> Maybe (DeclHead l)
forall a. a -> Maybe a
Just DeclHead l
dhead
getDeclHead (GDataDecl l
_ DataOrNew l
_ Maybe (Context l)
_ DeclHead l
dhead Maybe (Type l)
_ [GadtDecl l]
_ [Deriving l]
_) = DeclHead l -> Maybe (DeclHead l)
forall a. a -> Maybe a
Just DeclHead l
dhead
getDeclHead (DataFamDecl l
_ Maybe (Context l)
_ DeclHead l
dhead Maybe (ResultSig l)
_) = DeclHead l -> Maybe (DeclHead l)
forall a. a -> Maybe a
Just DeclHead l
dhead
getDeclHead (ClassDecl l
_ Maybe (Context l)
_ DeclHead l
dhead [FunDep l]
_ Maybe [ClassDecl l]
_) = DeclHead l -> Maybe (DeclHead l)
forall a. a -> Maybe a
Just DeclHead l
dhead
getDeclHead Decl l
_ = Maybe (DeclHead l)
forall a. Maybe a
Nothing

getDeclHeadName :: DeclHead l -> Name l
getDeclHeadName :: forall l. 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'

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

isTypeDecl :: Decl l -> Bool
isTypeDecl :: forall l. Decl l -> Bool
isTypeDecl (TypeDecl l
_ DeclHead l
_ Type l
_) = Bool
True
isTypeDecl (TypeFamDecl l
_ DeclHead l
_ Maybe (ResultSig l)
_ Maybe (InjectivityInfo l)
_) = Bool
True
isTypeDecl (DataDecl l
_ DataOrNew l
_ Maybe (Context l)
_ DeclHead l
_ [QualConDecl l]
_ [Deriving l]
_) = Bool
True
isTypeDecl (GDataDecl l
_ DataOrNew l
_ Maybe (Context l)
_ DeclHead l
_ Maybe (Type l)
_ [GadtDecl l]
_ [Deriving l]
_) = Bool
True
isTypeDecl (DataFamDecl l
_ Maybe (Context l)
_ DeclHead l
_ Maybe (ResultSig l)
_) = Bool
True
isTypeDecl Decl l
_ = Bool
False

opName :: Op l -> Name l
opName :: forall l. Op l -> Name l
opName (VarOp l
_ Name l
n) = Name l
n
opName (ConOp l
_ Name l
n) = Name l
n

isCon :: Name l -> Bool
isCon :: forall l. Name l -> Bool
isCon (Ident l
_ (Char
c:String
_)) = Char -> Bool
isUpper Char
c
isCon (Symbol l
_ (Char
':':String
_)) = Bool
True
isCon Name l
_ = Bool
False

nameToString :: Name l -> String
nameToString :: forall l. 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
isHSymbol 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

isHSymbol :: Char -> Bool
isHSymbol :: Char -> Bool
isHSymbol Char
c =
  Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
":!#%&*./?@\\-" Bool -> Bool -> Bool
||
  ((Char -> Bool
isSymbol Char
c Bool -> Bool -> Bool
|| Char -> Bool
isPunctuation Char
c) Bool -> Bool -> Bool
&& Bool -> Bool
not (Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"(),;[]`{}_\"'"))

specialConToString :: SpecialCon l -> String
specialConToString :: forall l. 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 :: forall l. 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 :: forall l (a :: * -> *).
(Ord l, Foldable a) =>
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 b a. (b -> a -> b) -> b -> a a -> b
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


getModuleExtensions :: Module l -> (Maybe Language, [Extension])
getModuleExtensions :: forall l. 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 a. [a] -> 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. HasCallStack => [a] -> a
last [Language]
langs, [Extension]
exts)