buildwrapper-0.8.11: src/Language/Haskell/BuildWrapper/Src.hs
{-# LANGUAGE TypeSynonymInstances,OverloadedStrings,CPP, PatternGuards #-}
-- |
-- Module : Language.Haskell.BuildWrapper.Src
-- Copyright : (c) JP Moresmau 2011
-- License : BSD3
--
-- Maintainer : jpmoresmau@gmail.com
-- Stability : beta
-- Portability : portable
--
-- Use haskell-src-exts to get a module outline
module Language.Haskell.BuildWrapper.Src where
import Data.Maybe (isNothing)
import Language.Haskell.BuildWrapper.Base
import Language.Haskell.Exts.Annotated
import Language.Haskell.Exts.Parser
import qualified Language.Haskell.Exts.Syntax as S
import qualified Data.Map as DM
import qualified Data.Text as T
import Data.Char (isSpace)
import Data.List (foldl', isPrefixOf)
import Control.Monad.Trans.State.Lazy (State, get, evalState, put, runState)
-- | get the AST
getHSEAST :: String -- ^ input text
-> [String] -- ^ options
-> ParseResult (Module SrcSpanInfo, [Comment])
getHSEAST input options=do
-- we add MultiParamTypeClasses because we may need it if the module we're parsing uses a type class with multiple parameters, which doesn't require the PRAGMA (only in the module DEFINING the type class)
-- we add PatternGuards since GHC only gives a warning if not explicit
-- we cannot add all the extensions because some conflict (NewQualifiedOperators breaks code with old operator syntax I think)
let
-- Parse options from options pragmas in source, since haskell-src-exts does not do it for us
input' = dropWhile (=='\n') . dropWhile (/='\n') $ input -- remove the first line, added by runCpphs (file: #line 1 "...")
topPragmas = case getTopPragmas input' of
ParseOk pragmas -> pragmas
_ -> []
optionsPragmas = [ optionsPragma | S.OptionsPragma _ _ optionsPragma <- topPragmas ]
optionsFromPragmas = concatMap words optionsPragmas
#if MIN_VERSION_haskell_src_exts(1,14,0)
exts=EnableExtension MultiParamTypeClasses : EnableExtension PatternGuards : map (\x->classifyExtension $ if "-X" `isPrefixOf` x then tail $ tail x else x) (options ++ optionsFromPragmas)
#else
exts=MultiParamTypeClasses : PatternGuards : map (\x->classifyExtension $ if "-X" `isPrefixOf` x then tail $ tail x else x) (options ++ optionsFromPragmas)
#endif
extsFull=if "-fglasgow-exts" `elem` options ++ optionsFromPragmas
then exts ++ glasgowExts
else exts
-- fixities necessary (see http://trac.haskell.org/haskell-src-exts/ticket/189 and https://sourceforge.net/projects/eclipsefp/forums/forum/371922/topic/4808590)
parseMode=defaultParseMode {extensions=extsFull,ignoreLinePragmas=False,ignoreLanguagePragmas=False,fixities = Just baseFixities}
parseFileContentsWithComments parseMode input
-- | get the ouline from the AST
getHSEOutline :: (Module SrcSpanInfo, [Comment]) -- ^ the commented AST
-> [OutlineDef]
getHSEOutline (Module _ _ _ _ decls,comments)=let
odecls = concatMap declOutline decls
(d2,m2) = runState (mapM (addComment False) odecls) $ commentMap
in evalState (mapM (addComment True) d2) m2
where
declOutline :: Decl SrcSpanInfo -> [OutlineDef]
declOutline (DataFamDecl l _ h _) = [mkOutlineDef (headDecl h) [Data,Family] (makeSpan l)]
declOutline (DataInsDecl l _ t cons _) = [mkOutlineDefWithChildren (typeDecl t) [Data,Instance] (makeSpan l) (map qualConDeclOutline cons)]
--declOutline (GDataInsDecl l _ t cons _) = [OutlineDef (typeDecl t) [Data,Instance] (makeSpan l) (map qualConDeclOutline cons)]
declOutline (DataDecl l _ _ h cons _) = [mkOutlineDefWithChildren (headDecl h) [Data] (makeSpan l) (map qualConDeclOutline cons)]
--declOutline (GDataDecl l _ _ h cons _) = [OutlineDef (headDecl h) [Data] (makeSpan l) (map qualConDeclOutline cons)]
declOutline (TypeFamDecl l h _) = [mkOutlineDef (headDecl h) [Type,Family] (makeSpan l)]
declOutline (TypeInsDecl l t1 _) = [mkOutlineDef (typeDecl t1) [Type,Instance] (makeSpan l)] -- ++ " "++(typeDecl t2)
declOutline (TypeDecl l h t) = [OutlineDef (headDecl h) [Type] (makeSpan l) [] (Just $ typeDecl t) Nothing Nothing]
declOutline (ClassDecl l _ h _ cdecls) = [mkOutlineDefWithChildren (headDecl h) [Class] (makeSpan l) (maybe [] (concatMap classDecl) cdecls)]
declOutline (FunBind l matches) = let
n=matchDecl $ head matches
(ty,l2)=addTypeInfo n l
in [OutlineDef n [Function] (makeSpan l2) [] ty Nothing Nothing]
#if MIN_VERSION_haskell_src_exts(1,16,0)
declOutline (PatBind l (PVar _ n) _ _)=let
#else
declOutline (PatBind l (PVar _ n) _ _ _)=let
#endif
nd=nameDecl n
(ty,l2)=addTypeInfo nd l
in [OutlineDef nd [Function] (makeSpan l2) [] ty Nothing Nothing]
#if MIN_VERSION_haskell_src_exts(1,16,0)
declOutline (InstDecl l _ h idecls)=[mkOutlineDefWithChildren (iheadRule h) [Instance] (makeSpan l) (maybe [] (concatMap instDecl) idecls)]
#else
declOutline (InstDecl l _ h idecls)=[mkOutlineDefWithChildren (iheadDecl h) [Instance] (makeSpan l) (maybe [] (concatMap instDecl) idecls)]
#endif
declOutline (SpliceDecl l e)=[mkOutlineDef (spliceDecl e) [Splice] (makeSpan l)]
declOutline _ = []
#if MIN_VERSION_haskell_src_exts(1,16,0)
iheadRule (IRule _ _ _ h) =iheadDecl h
iheadRule (IParen _ r)=iheadRule r
#endif
qualConDeclOutline :: QualConDecl SrcSpanInfo-> OutlineDef
qualConDeclOutline (QualConDecl l _ _ con)=let
(n,defs)=conDecl con
in mkOutlineDefWithChildren n [Constructor] (makeSpan l) defs
declOutlineInClass :: Decl SrcSpanInfo -> [OutlineDef]
declOutlineInClass (TypeSig l ns _)=map (\n->mkOutlineDef (nameDecl n) [Function] (makeSpan l)) ns
declOutlineInClass o=declOutline o
headDecl :: DeclHead a -> T.Text
#if MIN_VERSION_haskell_src_exts(1,16,0)
headDecl (DHead _ n )=nameDecl n
headDecl (DHInfix _ _ n)=nameDecl n
headDecl (DHApp _ h _)=headDecl h
#else
headDecl (DHead _ n _)=nameDecl n
headDecl (DHInfix _ _ n _)=nameDecl n
#endif
headDecl (DHParen _ h)=headDecl h
typeDecl :: Type SrcSpanInfo -> T.Text
-- typeDecl (TyForall _ mb mc t)=typeDecl t
-- typeDecl (TyVar _ n )=nameDecl n
-- typeDecl (TyCon _ qn )=qnameDecl qn
-- typeDecl (TyList _ t )=T.concat ["[", typeDecl t, "]"]
-- typeDecl (TyParen _ t )=typeDecl t
-- typeDecl (TyApp _ t1 t2)=T.concat [typeDecl t1, " ", typeDecl t2]
-- typeDecl (TyFun _ t1 t2)=T.concat [typeDecl t1, " -> ", typeDecl t2]
typeDecl = T.pack . prettyPrint
matchDecl :: Match a -> T.Text
matchDecl (Match _ n _ _ _)=nameDecl n
matchDecl (InfixMatch _ _ n _ _ _)=nameDecl n
iheadDecl :: InstHead SrcSpanInfo -> T.Text
#if MIN_VERSION_haskell_src_exts(1,16,0)
iheadDecl (IHCon _ qn)= qnameDecl qn
iheadDecl (IHApp _ i t)= T.concat [iheadDecl i, " ",typeDecl t]
iheadDecl (IHInfix _ t1 qn)= T.concat [typeDecl t1, " ", qnameDecl qn]
#else
iheadDecl (IHead _ qn ts)= T.concat [qnameDecl qn, " ", T.intercalate " " (map typeDecl ts)]
iheadDecl (IHInfix _ t1 qn t2)= T.concat [typeDecl t1, " ", qnameDecl qn, " ", typeDecl t2]
#endif
iheadDecl (IHParen _ i)=iheadDecl i
conDecl :: ConDecl SrcSpanInfo -> (T.Text,[OutlineDef])
conDecl (ConDecl _ n _)=(nameDecl n,[])
conDecl (InfixConDecl _ _ n _)=(nameDecl n,[])
conDecl (RecDecl _ n fields)=(nameDecl n,concatMap fieldDecl fields)
fieldDecl :: FieldDecl SrcSpanInfo -> [OutlineDef]
fieldDecl (FieldDecl l ns _)=map (\n->mkOutlineDef (nameDecl n) [Field] (makeSpan l)) ns
classDecl :: ClassDecl SrcSpanInfo -> [OutlineDef]
classDecl (ClsDecl _ d) = declOutlineInClass d
classDecl _ = []
instDecl :: InstDecl SrcSpanInfo -> [OutlineDef]
instDecl (InsDecl _ d) = declOutlineInClass d
instDecl _ = []
spliceDecl :: Exp SrcSpanInfo -> T.Text
spliceDecl (SpliceExp _ sp)= spliceName sp
spliceDecl (App _ e1 _)=spliceDecl e1
spliceDecl (Var _ qn)=qnameDecl qn
spliceDecl _ = ""
spliceName :: Splice SrcSpanInfo -> T.Text
spliceName (IdSplice _ n)=T.pack n
spliceName (ParenSplice _ e)=spliceDecl e
-- | a type map name -> Type
typeMap :: DM.Map T.Text (T.Text,SrcSpanInfo)
typeMap = foldr buildTypeMap DM.empty decls
buildTypeMap :: Decl SrcSpanInfo -> DM.Map T.Text (T.Text,SrcSpanInfo) -> DM.Map T.Text (T.Text,SrcSpanInfo)
buildTypeMap (TypeSig ssi ns t) m=let
td=typeDecl t
in if T.null td
then m
else foldr (\n2 m2->DM.insert (nameDecl n2) (td,ssi) m2) m ns
buildTypeMap _ m=m
addTypeInfo :: T.Text -> SrcSpanInfo -> (Maybe T.Text,SrcSpanInfo)
addTypeInfo t ss1=let
m=DM.lookup t typeMap
in case m of
Nothing->(Nothing,ss1)
-- the type ends just before us: merge src info
Just (ty,ss2)->if srcSpanEndLine (srcInfoSpan ss2) == (srcSpanStartLine (srcInfoSpan ss1) - 1)
then (Just ty,combSpanInfo ss2 ss1)
else (Just ty,ss1)
commentMap:: DM.Map Int (Int,Int,Bool,T.Text)
commentMap = foldl' buildCommentMap DM.empty comments
addComment:: Bool -> OutlineDef -> State (DM.Map Int (Int,Int,Bool,T.Text)) OutlineDef
addComment checkNext od =do
cm<-get
let
st=iflLine $ ifsStart$ odLoc od
-- search for comment before declaration (line above, same column)
pl=map (flip DM.lookup cm) [st-1,st,st+1]
(cm2,od2)= if isNothing $ odComment od
then case (pl,checkNext) of
-- | stc <= iflColumn (ifsStart $ odLoc od)
-- stc )
((Just (_,stl,True,t):_),_)-> ( DM.delete (st-1) cm,od{odComment=Just t,odStartLineComment=Just stl})
((_:Just (_,_,False,t):_),_) -> (DM.delete st cm,od{odComment=Just t})
((_:_:Just (_,_,False,t):_),True) -> (DM.delete (st+1) cm,od{odComment=Just t})
_ -> (cm,od)
-- _ -> let
-- -- search for comment after declaration (same line)
-- pl2=DM.lookup st cm
-- in case pl2 of
-- Just (_,_,False,t)-> (DM.delete st cm,od{odComment=Just t})
-- Nothing -> (cm,od)
else (cm,od)
(children,cm3)=runState (mapM (addComment checkNext) $ odChildren od2) cm2
put cm3
return od2{odChildren=children}
getHSEOutline _ = []
-- | get the ouline from the AST
getModuleLocation :: (Module SrcSpanInfo, [Comment]) -- ^ the commented AST
-> Maybe InFileSpan
getModuleLocation (Module _ (Just (ModuleHead _ (ModuleName l _) _ _)) _ _ _,_)=Just $ makeSpan l
getModuleLocation (Module l _ _ _ _,_)=Just $ makeSpan l
getModuleLocation _=Nothing
-- | build the comment map
buildCommentMap :: DM.Map Int (Int,Int,Bool,T.Text) -- ^ the map: key is line, value is start column, start line, comment is for after/before, and comment text
-> Comment -- ^ the comment
-> DM.Map Int (Int,Int,Bool,T.Text)
buildCommentMap m (Comment _ ss txt)=let
txtTrimmed=dropWhile isSpace txt
st=srcSpanStartLine ss
stc=srcSpanStartColumn ss
in case txtTrimmed of
('|':rest)->DM.insert (srcSpanEndLine ss) (stc,srcSpanStartLine ss,True,T.pack $ dropWhile isSpace rest) m
('^':rest)->DM.insert st (-1,st,False,T.pack $ dropWhile isSpace rest) m
-- we merge the comment text with the comment before it
_ | Just (stc2,sl,pos,t) <- DM.lookup (st-1) m -> let
-- to lookup properly we use the last line for pre comment and the first for post comments
key = if pos then st else st-1
in DM.insert key (stc2,sl,pos,T.concat [t,"\n",T.pack txt]) $ DM.delete (st-1) m
_ -> m
-- | get the import/export declarations
getHSEImportExport :: (Module SrcSpanInfo, [Comment]) -- ^ the AST
-> ([ExportDef],[ImportDef])
getHSEImportExport (Module _ mhead _ imps _,_)=(headExp mhead,impDefs imps)
where
headExp :: Maybe (ModuleHead SrcSpanInfo) ->[ExportDef]
headExp (Just (ModuleHead _ _ _ (Just (ExportSpecList _ exps))))=map expExp exps
headExp _ = []
expExp :: ExportSpec SrcSpanInfo -> ExportDef
#if MIN_VERSION_haskell_src_exts(1,16,0)
expExp (EVar l _ qn) = ExportDef (qnameDecl qn) IEVar (makeSpan l) []
#else
expExp (EVar l qn) = ExportDef (qnameDecl qn) IEVar (makeSpan l) []
#endif
expExp (EAbs l qn) = ExportDef (qnameDecl qn) IEAbs (makeSpan l) []
expExp (EThingAll l qn) = ExportDef (qnameDecl qn) IEThingAll (makeSpan l) []
expExp (EThingWith l qn cns) = ExportDef (qnameDecl qn) IEThingWith (makeSpan l) (map cnameDecl cns)
expExp (EModuleContents l mn) = ExportDef (mnnameDecl mn) IEModule (makeSpan l) []
impDefs :: [ImportDecl SrcSpanInfo] -> [ImportDef]
impDefs=map impDef
impDef :: ImportDecl SrcSpanInfo -> ImportDef
#if MIN_VERSION_haskell_src_exts(1,16,0)
impDef (ImportDecl l m qual _ _ pkg al specs)=ImportDef (mnnameDecl m) (fmap T.pack pkg) (makeSpan l) qual (hide specs) (alias al) (children specs)
#else
impDef (ImportDecl l m qual _ pkg al specs)=ImportDef (mnnameDecl m) (fmap T.pack pkg) (makeSpan l) qual (hide specs) (alias al) (children specs)
#endif
hide :: Maybe (ImportSpecList a)-> Bool
hide (Just (ImportSpecList _ b _))=b
hide _=False
alias :: Maybe (ModuleName a) -> T.Text
alias (Just mn)=mnnameDecl mn
alias Nothing =""
children :: Maybe (ImportSpecList SrcSpanInfo) -> Maybe [ImportSpecDef]
children (Just (ImportSpecList _ _ ss))=Just $ map child ss
children Nothing = Nothing
child :: ImportSpec SrcSpanInfo -> ImportSpecDef
#if MIN_VERSION_haskell_src_exts(1,16,0)
child (IVar l _ n)=ImportSpecDef (nameDecl n) IEVar (makeSpan l) []
#else
child (IVar l n)=ImportSpecDef (nameDecl n) IEVar (makeSpan l) []
#endif
child (IAbs l n)=ImportSpecDef (nameDecl n) IEAbs (makeSpan l) []
child (IThingAll l n) = ImportSpecDef (nameDecl n) IEThingAll (makeSpan l) []
child (IThingWith l n cns) = ImportSpecDef (nameDecl n) IEThingWith (makeSpan l) (map cnameDecl cns)
getHSEImportExport _=([],[])
-- | extract name
nameDecl :: Name a -> T.Text
nameDecl (Ident _ s)=T.pack s
nameDecl (Symbol _ s)=T.pack s
-- | extract class name
cnameDecl :: CName a -> T.Text
cnameDecl (VarName _ s)=nameDecl s
cnameDecl (ConName _ s)=nameDecl s
-- | extract qualified name
qnameDecl :: QName a -> T.Text
qnameDecl (Qual _ _ n)=nameDecl n
qnameDecl (UnQual _ n)=nameDecl n
qnameDecl _ =""
-- | extract module name
mnnameDecl :: ModuleName a -> T.Text
mnnameDecl (ModuleName _ s)=T.pack s
-- | convert a HSE span into a buildwrapper span
makeSpan :: SrcSpanInfo -> InFileSpan
makeSpan si=let
sis=srcInfoSpan si
(sl,sc)=srcSpanStart sis
(el,ec)=srcSpanEnd sis
in InFileSpan (InFileLoc sl sc) (InFileLoc el ec)
-- | all known extensions, as string
knownExtensionNames :: [String]
knownExtensionNames = map show knownExtensions