239 lines
7.6 KiB
Haskell
239 lines
7.6 KiB
Haskell
{-# OPTIONS -fglasgow-exts #-}
|
|
--
|
|
-- Copyright (C) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons
|
|
--
|
|
-- This program is free software; you can redistribute it and/or
|
|
-- modify it under the terms of the GNU General Public License as
|
|
-- published by the Free Software Foundation; either version 2 of
|
|
-- the License, or (at your option) any later version.
|
|
--
|
|
-- This program is distributed in the hope that it will be useful,
|
|
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
-- General Public License for more details.
|
|
--
|
|
-- You should have received a copy of the GNU General Public License
|
|
-- along with this program; if not, write to the Free Software
|
|
-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
|
-- 02111-1307, USA.
|
|
--
|
|
|
|
module System.Plugins.Parser (
|
|
parse, mergeModules, pretty, parsePragmas,
|
|
HsModule(..) ,
|
|
replaceModName
|
|
) where
|
|
|
|
#include "../../config.h"
|
|
|
|
import Data.List
|
|
import Data.Char
|
|
import Data.Either
|
|
|
|
#if defined(WITH_HSX)
|
|
import Language.Haskell.Hsx
|
|
#else
|
|
import Language.Haskell.Parser
|
|
import Language.Haskell.Syntax
|
|
import Language.Haskell.Pretty
|
|
#endif
|
|
|
|
--
|
|
-- | parse a file (as a string) as Haskell src
|
|
--
|
|
parse :: FilePath -- ^ module name
|
|
-> String -- ^ haskell src
|
|
-> Either String HsModule -- ^ abstract syntax
|
|
|
|
parse f fsrc =
|
|
#if defined(WITH_HSX)
|
|
case parseFileContentsWithMode (ParseMode f) fsrc of
|
|
#else
|
|
case parseModuleWithMode (ParseMode f) fsrc of
|
|
#endif
|
|
ParseOk src -> Right src
|
|
ParseFailed loc _ -> Left $ srcmsg loc
|
|
where
|
|
srcmsg loc = "parse error in " ++ f ++ "\n" ++
|
|
"line: " ++ (show $ srcLine loc) ++
|
|
", col: " ++ (show $ srcColumn loc)++ "\n"
|
|
|
|
--
|
|
-- | pretty print haskell src
|
|
--
|
|
-- doesn't handle operators with '#' at the end. i.e. unsafeCoerce#
|
|
--
|
|
pretty :: HsModule -> String
|
|
pretty code = prettyPrintWithMode (defaultMode { linePragmas = True }) code
|
|
|
|
|
|
-- | mergeModules : generate a full Haskell src file, give a .hs config
|
|
-- file, and a stub to take default syntax and decls from. Mostly we
|
|
-- just ensure they don't do anything bad, and that the names are
|
|
-- correct for the module.
|
|
--
|
|
-- Transformations:
|
|
--
|
|
-- . Take src location pragmas from the conf file (1st file)
|
|
-- . Use the template's (2nd argument) module name
|
|
-- . Only use export list from template (2nd arg)
|
|
-- . Merge top-level decls
|
|
-- . need to force the type of the plugin to match the stub,
|
|
-- overwriting any type they supply.
|
|
--
|
|
mergeModules :: HsModule -> -- Configure module
|
|
HsModule -> -- Template module
|
|
HsModule -- A merge of the two
|
|
|
|
mergeModules (HsModule l _ _ is ds )
|
|
(HsModule _ m' es' is' ds')
|
|
= (HsModule l m' es'
|
|
(mImps m' is is')
|
|
(mDecl ds ds') )
|
|
|
|
--
|
|
-- | replace Module name with String.
|
|
--
|
|
replaceModName :: HsModule -> String -> HsModule
|
|
replaceModName (HsModule l _ es is ds) nm = (HsModule l (Module nm) es is ds)
|
|
|
|
--
|
|
-- | merge import declarations:
|
|
--
|
|
-- * ensure that the config file doesn't import the stub name
|
|
-- * merge import lists uniquely, and when they match, merge their decls
|
|
--
|
|
-- TODO * we don't merge imports of the same module from both files.
|
|
-- We should, and then merge the decls in their import list
|
|
-- * rename args, too confusing.
|
|
--
|
|
-- quick fix: strip all type signatures from the source.
|
|
--
|
|
mImps :: Module -> -- plugin module name
|
|
[HsImportDecl] -> -- conf file imports
|
|
[HsImportDecl] -> -- stub file imports
|
|
[HsImportDecl]
|
|
|
|
mImps plug_mod cimps timps =
|
|
case filter (!~ self) cimps of cimps' -> unionBy (=~) cimps' timps
|
|
where
|
|
self = ( HsImportDecl undefined plug_mod undefined undefined undefined )
|
|
|
|
--
|
|
-- | merge top-level declarations
|
|
--
|
|
-- Remove decls found in template, using those from the config file.
|
|
-- Need to sort decls by types, then decls first, in both.
|
|
--
|
|
-- Could we write a pass to handle editor, foo :: String ?
|
|
-- We must keep the type from the template.
|
|
--
|
|
mDecl ds es = let ds' = filter (not.typeDecl) ds
|
|
in sortBy decls $! unionBy (=~) ds' es
|
|
where
|
|
decls a b = compare (encoding a) (encoding b)
|
|
|
|
typeDecl :: HsDecl -> Bool
|
|
typeDecl (HsTypeSig _ _ _) = True
|
|
typeDecl _ = False
|
|
|
|
encoding :: HsDecl -> Int
|
|
encoding d = case d of
|
|
HsFunBind _ -> 1
|
|
HsPatBind _ _ _ _ -> 1
|
|
_ -> 0
|
|
|
|
--
|
|
-- syntactic equality over the useful Haskell abstract syntax
|
|
-- this may be extended if we try to merge the files more thoroughly
|
|
--
|
|
class SynEq a where
|
|
(=~) :: a -> a -> Bool
|
|
(!~) :: a -> a -> Bool
|
|
n !~ m = not (n =~ m)
|
|
|
|
instance SynEq HsDecl where
|
|
(HsPatBind _ (HsPVar n) _ _) =~ (HsPatBind _ (HsPVar m) _ _) = n == m
|
|
(HsTypeSig _ (n:_) _) =~ (HsTypeSig _ (m:_) _) = n == m
|
|
_ =~ _ = False
|
|
|
|
instance SynEq HsImportDecl where
|
|
(HsImportDecl _ m _ _ _) =~ (HsImportDecl _ n _ _ _) = n == m
|
|
|
|
|
|
--
|
|
-- | Parsing option pragmas.
|
|
--
|
|
-- This is not a type checker. If the user supplies bogus options,
|
|
-- they'll get slightly mystical error messages. Also, we /want/ to
|
|
-- handle -package options, and other /static/ flags. This is more than
|
|
-- GHC.
|
|
--
|
|
-- GHC user's guide :
|
|
--
|
|
-- > OPTIONS pragmas are only looked for at the top of your source
|
|
-- > files, up to the first (non-literate,non-empty) line not
|
|
-- > containing OPTIONS. Multiple OPTIONS pragmas are recognised.
|
|
--
|
|
-- based on getOptionsFromSource(), in main\/DriverUtil.hs
|
|
--
|
|
parsePragmas :: String -- ^ input src
|
|
-> ([String],[String]) -- ^ normal options, global options
|
|
|
|
parsePragmas s = look $ lines s
|
|
where
|
|
look [] = ([],[])
|
|
look (l':ls) =
|
|
let l = remove_spaces l'
|
|
in case () of
|
|
() | null l -> look ls
|
|
| prefixMatch "#" l -> look ls
|
|
| prefixMatch "{-# LINE" l -> look ls
|
|
| Just (Option o) <- matchPragma l
|
|
-> let (as,bs) = look ls in (words o ++ as,bs)
|
|
| Just (Global g) <- matchPragma l
|
|
-> let (as,bs) = look ls in (as,words g ++ bs)
|
|
| otherwise -> ([],[])
|
|
|
|
--
|
|
-- based on main\/DriverUtil.hs
|
|
--
|
|
-- extended to handle dynamic options too
|
|
--
|
|
|
|
data Pragma = Option !String | Global !String
|
|
|
|
matchPragma :: String -> Maybe Pragma
|
|
matchPragma s
|
|
| Just s1 <- maybePrefixMatch "{-#" s, -- -}
|
|
Just s2 <- maybePrefixMatch "OPTIONS" (remove_spaces s1),
|
|
Just s3 <- maybePrefixMatch "}-#" (reverse s2)
|
|
= Just (Option (reverse s3))
|
|
|
|
| Just s1 <- maybePrefixMatch "{-#" s, -- -}
|
|
Just s2 <- maybePrefixMatch "GLOBALOPTIONS" (remove_spaces s1),
|
|
Just s3 <- maybePrefixMatch "}-#" (reverse s2)
|
|
= Just (Global (reverse s3))
|
|
|
|
| otherwise
|
|
= Nothing
|
|
|
|
remove_spaces :: String -> String
|
|
remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
|
|
|
|
--
|
|
-- verbatim from utils\/Utils.lhs
|
|
--
|
|
prefixMatch :: Eq a => [a] -> [a] -> Bool
|
|
prefixMatch [] _str = True
|
|
prefixMatch _pat [] = False
|
|
prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss
|
|
| otherwise = False
|
|
|
|
maybePrefixMatch :: String -> String -> Maybe String
|
|
maybePrefixMatch [] rest = Just rest
|
|
maybePrefixMatch (_:_) [] = Nothing
|
|
maybePrefixMatch (p:pat) (r:rest)
|
|
| p == r = maybePrefixMatch pat rest
|
|
| otherwise = Nothing
|