import Prelude hiding (lookup)
import Language.Haskell.Exts hiding (ModuleName)
import qualified Language.Haskell.Exts as LH
import Documentation.Haddock hiding (Decl)
import Control.Monad.State
import Data.Maybe
import Data.List (find,intercalate)
import qualified Name as GHC
import qualified Outputable as GHC
import qualified Module as GHC
import Text.Parsec
import Text.Parsec.String
import Data.Map hiding (filter)
import System.FilePath (dropFileName)
import System.Directory (createDirectoryIfMissing,doesFileExist)
import Data.Char (isAlpha)
import System.IO (hFlush,stdout)
import Control.Monad (filterM)
-- Cabal
import Distribution.PackageDescription
(exposedModules,condTreeData,condLibrary)
import Distribution.PackageDescription.Parse
(readPackageDescription)
import Distribution.Verbosity (silent)
import Distribution.ModuleName (components)
-- | Module names are written with 'String's.
type ModuleName = String
-- | The name of a monad version of one module is the
-- the name of that module followed by @.Monad@.
monadMName :: ModuleName -- Original module name
-> ModuleName -- New module name
monadMName mn = mn ++ ".Monad"
-- | We skip to parse files in this list.
blacklist :: [ModuleName]
blacklist =
[ -- "Text.LaTeX.Base.Parser" -- See issue #1: <https://github.com/Daniel-Diaz/HaTeX/issues/1>
]
-- | All exposed modules of HaTeX.
allExposed :: IO [ModuleName]
allExposed =
fmap
( filter (`notElem` blacklist)
. fmap (intercalate "." . components)
. exposedModules . condTreeData . fromJust . condLibrary)
$ readPackageDescription silent "HaTeX.cabal"
-- | The list of modules to be transformed by HaTeX-meta.
moduleList :: IO [ModuleName]
moduleList =
allExposed >>=
filterM
(fmap hatexPragma . parseFileS . mNameToFilePath)
parseFileS :: FilePath -> IO Module
parseFileS fp =
(do exst <- doesFileExist fp
if exst then do r <- parseFileWithMode (defaultParseMode { fixities = Nothing , extensions = [CPP] }) fp
case r of
ParseFailed l s -> do putStrLn $ "HaTeX-meta: Parsing error at " ++ prettyPrint l
++ " (" ++ fp ++ "): " ++ s ++ "."
return defaultModule
ParseOk m -> return m
else return defaultModule ) `catch` \e -> do
-- When a exception is raised...
putStrLn $ "HaTeX-meta: There was an exception reading " ++ name ++ " module."
putStrLn "The exception was:"
print e
return defaultModule
where
name = filePathToMName fp
defaultModule = Module loc0 (LH.ModuleName name) [] Nothing Nothing [] []
-- | Check if a module has the HaTeX /MakeMonadic/ option:
--
-- > {-# OPTIONS_HATEX MakeMonadic #-}
hatexPragma :: Module -> Bool
hatexPragma (Module _ _ pragmas _ _ _ _) = any isMonadicPragma pragmas
isMonadicPragma :: ModulePragma -> Bool
isMonadicPragma (OptionsPragma _ (Just (UnknownTool "HATEX")) str) =
takeWhile isAlpha str == "MakeMonadic"
isMonadicPragma _ = False
-- | Get the 'FilePath' of a 'ModuleName'.
mNameToFilePath :: ModuleName -> FilePath
mNameToFilePath = (++ ".hs") . fmap (\c -> if c == '.' then '/' else c)
filePathToMName :: FilePath -> ModuleName
filePathToMName = fmap (\c -> if c == '/' then '.' else c) . reverse . drop 3 . reverse
nameString :: Name -> String
nameString = prettyPrint
snd3 :: (a,b,c) -> b
snd3 (_,x,_) = x
unlines2 :: [String] -> String
unlines2 = intercalate "\n\n"
ghcName :: GHC.Name -> String
ghcName = GHC.occNameString . GHC.nameOccName
loc0 :: SrcLoc
loc0 = SrcLoc [] 0 0
symbolParens :: String -> String
symbolParens [] = []
symbolParens str@(x:_) =
if isAlpha x then str
else "(" ++ str ++ ")"
--------------
data FunDoc = FD
{ funName :: String
, funDoc :: Maybe (Doc GHC.Name)
, funArgsDoc :: FnArgsDoc GHC.Name
}
data HSInfo = HSI
{ hsModuleName :: ModuleName
, hsPragma :: String
, hsModuleInfo :: Maybe (Doc GHC.Name)
, hsExportList :: String
, hsTypeNames :: [String]
, hsFunInfo :: [(FunDoc,Type)]
}
getHSInfo :: ModuleName -> Interface -> IO HSInfo
getHSInfo mn i = do
let fp = mNameToFilePath mn
-- Parsing module
pr <- parseFileWithMode (defaultParseMode { fixities = Nothing }) fp
(Module _ _ pragmas _ _ imports decls)
<- case pr of
ParseOk x -> return x
ParseFailed loc err -> fail $ show loc ++ ":" ++ err
-- Getting export list
let exportListParser :: Parser String
exportListParser = do
manyTill anyChar (try $ string $ "module " ++ mn)
str <- manyTill anyChar (try $ string $ "where")
return $ "module " ++ monadMName mn ++ str ++ "where"
getExportList :: IO String
getExportList = do
pr <- parseFromFile exportListParser fp
case pr of
Left err -> fail $ "getExportList: parse error: " ++ show err
Right str -> return str
expList <- getExportList
-- Exported names
let exportedNames = fmap (symbolParens . ghcName) $ ifaceExports i
-- Getting type names
let getTypeName :: Decl -> Maybe String
getTypeName (TypeDecl _ n _ _) = Just $ nameString n
getTypeName (DataDecl _ _ _ n _ _ _) = Just $ nameString n
getTypeName _ = Nothing
-- Getting functions info
let getFunInfo :: Decl -> [(FunDoc,Type)]
getFunInfo (TypeSig _ ns_ t) =
let ns = filter (`elem` exportedNames) $ fmap nameString ns_
funmap = ifaceDeclMap i
strfunmap = mapKeys ghcName funmap
in fmap (\n -> let dinfo = lookup n strfunmap
(fd,fad) = maybe (Nothing,Data.Map.empty) snd3 dinfo
in ( FD n fd fad , t )) ns
getFunInfo _ = []
-- Final result
return $
HSI { hsModuleName = mn
, hsPragma = unlines $ fmap prettyPrint
$ filter (not . isMonadicPragma) $ pragmas
, hsModuleInfo = ifaceDoc i
, hsExportList = expList
, hsTypeNames = catMaybes $ fmap getTypeName decls
, hsFunInfo = concat $ fmap getFunInfo decls
}
-- Rendering Doc
renderDoc :: Doc GHC.Name -> String
renderDoc DocEmpty = []
renderDoc (DocAppend d1 d2) = renderDoc d1 ++ renderDoc d2
renderDoc (DocString str) = str
renderDoc (DocParagraph d) = renderDoc d
renderDoc (DocIdentifier xs) = "'" ++ ghcName (last xs) ++ "'"
renderDoc (DocModule str) = "\"" ++ str ++ "\""
renderDoc (DocEmphasis d) = "/" ++ renderDoc d ++ "/"
renderDoc (DocMonospaced d) = "@" ++ renderDoc d ++ "@"
renderDoc (DocUnorderedList xs) = unlines2 $ fmap renderDoc xs
renderDoc (DocOrderedList xs) = unlines2
$ zipWith (++) (fmap (\n -> show n ++ ". ") [1 .. ])
$ fmap renderDoc xs
renderDoc (DocCodeBlock d) = "\n> " ++ renderDoc d ++ "\n"
renderDoc (DocURL str) = "<" ++ str ++ ">"
docCommenting :: String -> String
docCommenting str =
let lns = length $ lines str
in if lns > 1 then "{-|\n" ++ str ++ "-}"
else "-- | " ++ str
docString :: Doc GHC.Name -> String
docString = docCommenting . renderDoc
-- Type synonyms
typeSynonym :: String -> String
typeSynonym t = unwords [ "type" , t , "=" , "App." ++ t ]
-- Monadic functions
namesInType :: Type -> [String]
namesInType (TyForall _ _ t) = namesInType t
namesInType (TyFun t1 t2) = namesInType t1 ++ namesInType t2
namesInType (TyTuple _ ts) = concat $ fmap namesInType ts
namesInType (TyList t) = namesInType t
namesInType (TyApp t1 t2) = namesInType t1 ++ namesInType t2
namesInType (TyVar _) = []
namesInType (TyCon qn) = [prettyPrint qn]
namesInType (TyParen t) = namesInType t
latexType :: Type -> Type
latexType (TyForall m c t) = TyForall m c $ latexType t
latexType (TyFun t1 t2) = latexType t1 `TyFun` latexType t2
latexType (TyTuple b ts) = TyTuple b $ fmap latexType ts
latexType (TyList t) = TyList $ latexType t
latexType (TyApp t1 t2) = TyApp (latexType t1) (latexType t2)
latexType (TyVar v) = TyVar v
latexType (TyCon (UnQual (Ident "LaTeX"))) = TyApp (TyCon $ UnQual $ Ident "LaTeXT_")
(TyVar $ Ident "m")
latexType (TyCon qn) = TyCon qn
latexType (TyParen t) = TyParen $ latexType t
argNumber :: Type -> Int
argNumber (TyForall _ _ t) = argNumber t
argNumber (TyFun t1 t2) = argNumber t1 + argNumber t2
argNumber _ = 1
typeList :: Type -> [Type]
typeList (TyForall _ _ t) = typeList t
typeList (TyFun t1 t2) = typeList t1 ++ typeList t2
typeList t = [t]
doStatement :: Pat -> Type -> Maybe Stmt
doStatement v@(PVar n) (TyCon (UnQual (Ident "LaTeX"))) = Just $
Generator loc0 v $ App (Var $ UnQual $ Ident "extractLaTeX_")
$ Var $ UnQual n
doStatement v@(PVar n) (TyList (TyCon (UnQual (Ident "LaTeX")))) = Just $
Generator loc0 v $ foldl1 App
[ Var $ UnQual $ Ident "mapM"
, Var $ UnQual $ Ident "extractLaTeX_"
, Var $ UnQual n ]
doStatement v@(PVar n) (TyApp (TyCon (UnQual (Ident "Maybe")))
(TyCon (UnQual (Ident "LaTeX")))) = Just $
Generator loc0 v $ foldl1 App
[ Var $ UnQual $ Ident "maybe"
, App (Var $ UnQual $ Ident "return") (Con $ UnQual $ Ident "Nothing")
, InfixApp (RightSection (QVarOp $ UnQual $ Symbol ">>=")
(InfixApp (Var $ UnQual $ Ident "return")
(QVarOp $ UnQual $ Symbol ".")
(Con $ UnQual $ Ident "Just") ) )
(QVarOp $ UnQual $ Symbol ".")
(Var $ UnQual $ Ident "extractLaTeX_")
, Var $ UnQual n
]
doStatement _ _ = Nothing
qualify :: String -> String
qualify [] = []
qualify str@(x:_) = if isAlpha x then "App." ++ str
else "(App." ++ (tail $ init $ str) ++ ")"
monadicFunction :: (FunDoc,Type) -> String
monadicFunction (fd,t) =
let n :: String
n = funName fd
varsn :: [Name]
varsn = fmap (Ident . ('a':) . show) [1 .. argNumber t - 1]
vars :: [Pat]
vars = fmap PVar varsn
varse :: [Exp]
varse = fmap (Var . UnQual) varsn
lastStmt = Qualifier $ App (Var $ UnQual $ Ident "textell")
$ foldl App (Var $ UnQual $ Ident [])
$ (Var $ UnQual $ Ident $ qualify n) : varse
in
if elem "LaTeX" (namesInType t)
then unlines [ maybe [] docString $ funDoc fd
, unwords [n , "::" , prettyPrint
$ TyForall Nothing
[ClassA (UnQual $ Ident "Monad")
[TyVar $ Ident "m"]
]
$ latexType t]
, prettyPrint
$ FunBind [Match loc0
(Ident n)
vars
Nothing
(UnGuardedRhs $ Do $ (++[lastStmt]) $ catMaybes
$ zipWith doStatement vars $ init $ typeList t )
(BDecls []) ]
]
else unlines [ maybe [] docString $ funDoc fd
, unwords [n , "::" , prettyPrint t]
, unwords [n , "=" , qualify n] ]
-- Import list string
importString :: HSInfo -> String
importString hsi =
let mn = hsModuleName hsi
in
unlines [
"import Text.LaTeX.Base.Writer"
, "import Text.LaTeX.Base.Render"
, "import Text.LaTeX.Base.Types"
, "import qualified " ++ mn ++ " as App"
, "import " ++ mn ++ "(" ++ intercalate "," (hsTypeNames hsi) ++ ")"
]
-- HaTeX-meta warning
hatexmetawarn :: ModuleName -> String
hatexmetawarn mn = unlines $ fmap ("-- "++) $ [
""
, "/For contributors: This module was automatically generated by HaTeX-meta./"
, "/So, please, don't make any change here directly, because/"
, "/this is intended to be generated automatically from/"
, "\"" ++ mn ++ "\" /module via HaTeX-meta,/"
, "/and therefore, changes must to be done in these places./"
]
-- Building the monad module
buildMonadModule :: HSInfo -> String
buildMonadModule hsi = unlines [
hsPragma hsi
, concat [ maybe "-- |\n" docString $ hsModuleInfo hsi
, hatexmetawarn $ hsModuleName hsi ]
, hsExportList hsi ++ "\n"
, importString hsi
, unlines $ fmap monadicFunction $ hsFunInfo hsi
]
-- Main function
main :: IO ()
main = do
putStrLn "HaTeX-meta: Modules to be processed:"
mlist <- moduleList
mapM_ (putStrLn . ("* " ++)) mlist
is <- createInterfaces [] mlist
mapM_ (\m -> do putStr $ "HaTeX-meta: Processing " ++ m ++ "... "
hFlush stdout
let fp = mNameToFilePath m
fp' = mNameToFilePath $ monadMName m
i = fromJust $ find (\x -> (GHC.moduleNameString
$ GHC.moduleName
$ ifaceMod x) == m) is
createDirectoryIfMissing True $ dropFileName fp'
getHSInfo m i >>= writeFile fp' . buildMonadModule
putStrLn "Done."
) mlist