230 lines
7.4 KiB
Haskell
230 lines
7.4 KiB
Haskell
|
{-# OPTIONS -fglasgow-exts #-}
|
||
|
--
|
||
|
-- Copyright (C) 2004 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 Plugins.Parser (
|
||
|
parse, mergeModules, pretty, parsePragmas,
|
||
|
HsModule(..) ,
|
||
|
replaceModName
|
||
|
) where
|
||
|
|
||
|
import Data.List
|
||
|
import Data.Char
|
||
|
import Data.Either
|
||
|
|
||
|
import Language.Haskell.Parser
|
||
|
import Language.Haskell.Syntax
|
||
|
import Language.Haskell.Pretty
|
||
|
|
||
|
--
|
||
|
-- | parse a file (as a string) as Haskell src
|
||
|
--
|
||
|
parse :: FilePath -- ^ module name
|
||
|
-> String -- ^ haskell src
|
||
|
-> Either String HsModule -- ^ abstract syntax
|
||
|
|
||
|
parse f fsrc =
|
||
|
case parseModuleWithMode (ParseMode f) fsrc of
|
||
|
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 (\t->not $ typeDecl t) ds -- rm type sigs from plugin
|
||
|
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, upto 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
|