{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
--
-- 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 :: FilePath -> FilePath -> Either FilePath HsModule
parse FilePath
f FilePath
fsrc =
#if defined(WITH_HSX)
    case parseFileContentsWithMode (ParseMode f) fsrc of
#else
    case ParseMode -> FilePath -> ParseResult HsModule
parseModuleWithMode (FilePath -> ParseMode
ParseMode FilePath
f) FilePath
fsrc of
#endif
        ParseOk HsModule
src       -> HsModule -> Either FilePath HsModule
forall a b. b -> Either a b
Right HsModule
src
        ParseFailed SrcLoc
loc FilePath
_ -> FilePath -> Either FilePath HsModule
forall a b. a -> Either a b
Left (FilePath -> Either FilePath HsModule)
-> FilePath -> Either FilePath HsModule
forall a b. (a -> b) -> a -> b
$ SrcLoc -> FilePath
srcmsg SrcLoc
loc
  where
    srcmsg :: SrcLoc -> FilePath
srcmsg SrcLoc
loc = FilePath
"parse error in " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
f FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                  FilePath
"line: "  FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ SrcLoc -> Int
srcLine SrcLoc
loc) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                  FilePath
", col: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ SrcLoc -> Int
srcColumn SrcLoc
loc)FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n"

--
-- | pretty print haskell src
--
-- doesn't handle operators with '#' at the end. i.e. unsafeCoerce#
--
pretty :: HsModule -> String
pretty :: HsModule -> FilePath
pretty HsModule
code = PPHsMode -> HsModule -> FilePath
forall a. Pretty a => PPHsMode -> a -> FilePath
prettyPrintWithMode (PPHsMode
defaultMode { linePragmas :: Bool
linePragmas = Bool
True }) HsModule
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 -> HsModule -> HsModule
mergeModules (HsModule SrcLoc
l  Module
_   Maybe [HsExportSpec]
_  [HsImportDecl]
is  [HsDecl]
ds )
             (HsModule SrcLoc
_  Module
m' Maybe [HsExportSpec]
es' [HsImportDecl]
is' [HsDecl]
ds')
         = (SrcLoc
-> Module
-> Maybe [HsExportSpec]
-> [HsImportDecl]
-> [HsDecl]
-> HsModule
HsModule SrcLoc
l  Module
m' Maybe [HsExportSpec]
es'
                        (Module -> [HsImportDecl] -> [HsImportDecl] -> [HsImportDecl]
mImps Module
m' [HsImportDecl]
is [HsImportDecl]
is')
                        ([HsDecl] -> [HsDecl] -> [HsDecl]
mDecl [HsDecl]
ds [HsDecl]
ds') )

--
-- | replace Module name with String.
--
replaceModName :: HsModule -> String -> HsModule
replaceModName :: HsModule -> FilePath -> HsModule
replaceModName (HsModule SrcLoc
l Module
_ Maybe [HsExportSpec]
es [HsImportDecl]
is [HsDecl]
ds) FilePath
nm = (SrcLoc
-> Module
-> Maybe [HsExportSpec]
-> [HsImportDecl]
-> [HsDecl]
-> HsModule
HsModule SrcLoc
l (FilePath -> Module
Module FilePath
nm) Maybe [HsExportSpec]
es [HsImportDecl]
is [HsDecl]
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 :: Module -> [HsImportDecl] -> [HsImportDecl] -> [HsImportDecl]
mImps Module
plug_mod [HsImportDecl]
cimps [HsImportDecl]
timps =
    case (HsImportDecl -> Bool) -> [HsImportDecl] -> [HsImportDecl]
forall a. (a -> Bool) -> [a] -> [a]
filter (HsImportDecl -> HsImportDecl -> Bool
forall a. SynEq a => a -> a -> Bool
!~ HsImportDecl
self) [HsImportDecl]
cimps of [HsImportDecl]
cimps' -> (HsImportDecl -> HsImportDecl -> Bool)
-> [HsImportDecl] -> [HsImportDecl] -> [HsImportDecl]
forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
unionBy HsImportDecl -> HsImportDecl -> Bool
forall a. SynEq a => a -> a -> Bool
(=~) [HsImportDecl]
cimps' [HsImportDecl]
timps
  where
    self :: HsImportDecl
self = ( SrcLoc
-> Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
HsImportDecl SrcLoc
forall a. HasCallStack => a
undefined Module
plug_mod Bool
forall a. HasCallStack => a
undefined Maybe Module
forall a. HasCallStack => a
undefined Maybe (Bool, [HsImportSpec])
forall a. HasCallStack => a
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 :: [HsDecl] -> [HsDecl] -> [HsDecl]
mDecl [HsDecl]
ds [HsDecl]
es = let ds' :: [HsDecl]
ds' = (HsDecl -> Bool) -> [HsDecl] -> [HsDecl]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> (HsDecl -> Bool) -> HsDecl -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.HsDecl -> Bool
typeDecl) [HsDecl]
ds
              in (HsDecl -> HsDecl -> Ordering) -> [HsDecl] -> [HsDecl]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy HsDecl -> HsDecl -> Ordering
decls ([HsDecl] -> [HsDecl]) -> [HsDecl] -> [HsDecl]
forall a b. (a -> b) -> a -> b
$! (HsDecl -> HsDecl -> Bool) -> [HsDecl] -> [HsDecl] -> [HsDecl]
forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
unionBy HsDecl -> HsDecl -> Bool
forall a. SynEq a => a -> a -> Bool
(=~) [HsDecl]
ds' [HsDecl]
es
  where
    decls :: HsDecl -> HsDecl -> Ordering
decls HsDecl
a HsDecl
b = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (HsDecl -> Int
encoding HsDecl
a) (HsDecl -> Int
encoding HsDecl
b)

    typeDecl :: HsDecl -> Bool
    typeDecl :: HsDecl -> Bool
typeDecl (HsTypeSig SrcLoc
_ [HsName]
_ HsQualType
_) = Bool
True
    typeDecl HsDecl
_ = Bool
False

    encoding :: HsDecl -> Int
    encoding :: HsDecl -> Int
encoding HsDecl
d = case HsDecl
d of
           HsFunBind [HsMatch]
_        -> Int
1
           HsPatBind SrcLoc
_ HsPat
_ HsRhs
_ [HsDecl]
_  -> Int
1
           HsDecl
_                  -> Int
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
    a
n !~ a
m = Bool -> Bool
not (a
n a -> a -> Bool
forall a. SynEq a => a -> a -> Bool
=~ a
m)

instance SynEq HsDecl where
    (HsPatBind SrcLoc
_ (HsPVar HsName
n) HsRhs
_ [HsDecl]
_) =~ :: HsDecl -> HsDecl -> Bool
=~ (HsPatBind SrcLoc
_ (HsPVar HsName
m) HsRhs
_ [HsDecl]
_) = HsName
n HsName -> HsName -> Bool
forall a. Eq a => a -> a -> Bool
== HsName
m
    (HsTypeSig SrcLoc
_ (HsName
n:[HsName]
_) HsQualType
_)        =~ (HsTypeSig SrcLoc
_ (HsName
m:[HsName]
_) HsQualType
_)        = HsName
n HsName -> HsName -> Bool
forall a. Eq a => a -> a -> Bool
== HsName
m
    HsDecl
_ =~ HsDecl
_ = Bool
False

instance SynEq HsImportDecl where
    (HsImportDecl SrcLoc
_ Module
m Bool
_ Maybe Module
_ Maybe (Bool, [HsImportSpec])
_) =~ :: HsImportDecl -> HsImportDecl -> Bool
=~ (HsImportDecl SrcLoc
_ Module
n Bool
_ Maybe Module
_ Maybe (Bool, [HsImportSpec])
_)    = Module
n Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
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 :: FilePath -> ([FilePath], [FilePath])
parsePragmas FilePath
s = [FilePath] -> ([FilePath], [FilePath])
look ([FilePath] -> ([FilePath], [FilePath]))
-> [FilePath] -> ([FilePath], [FilePath])
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
lines FilePath
s
    where
        look :: [FilePath] -> ([FilePath], [FilePath])
look [] = ([],[])
        look (FilePath
l':[FilePath]
ls) =
            let l :: FilePath
l = FilePath -> FilePath
remove_spaces FilePath
l'
            in case () of
                () | FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
l                      -> [FilePath] -> ([FilePath], [FilePath])
look [FilePath]
ls
                   | FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
prefixMatch FilePath
"#" FilePath
l           -> [FilePath] -> ([FilePath], [FilePath])
look [FilePath]
ls
                   | FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
prefixMatch FilePath
"{-# LINE" FilePath
l    -> [FilePath] -> ([FilePath], [FilePath])
look [FilePath]
ls
                   | Just (Option FilePath
o) <- FilePath -> Maybe Pragma
matchPragma FilePath
l
                        -> let ([FilePath]
as,[FilePath]
bs) = [FilePath] -> ([FilePath], [FilePath])
look [FilePath]
ls in (FilePath -> [FilePath]
words FilePath
o [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
as,[FilePath]
bs)
                   | Just (Global FilePath
g) <- FilePath -> Maybe Pragma
matchPragma FilePath
l
                        -> let ([FilePath]
as,[FilePath]
bs) = [FilePath] -> ([FilePath], [FilePath])
look [FilePath]
ls in ([FilePath]
as,FilePath -> [FilePath]
words FilePath
g [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
bs)
                   | Bool
otherwise -> ([],[])

--
-- based on main\/DriverUtil.hs
--
-- extended to handle dynamic options too
--

data Pragma = Option !String | Global !String

matchPragma :: String -> Maybe Pragma
matchPragma :: FilePath -> Maybe Pragma
matchPragma FilePath
s
        | Just FilePath
s1 <- FilePath -> FilePath -> Maybe FilePath
maybePrefixMatch FilePath
"{-#" FilePath
s, -- -}
          Just FilePath
s2 <- FilePath -> FilePath -> Maybe FilePath
maybePrefixMatch FilePath
"OPTIONS" (FilePath -> FilePath
remove_spaces FilePath
s1),
          Just FilePath
s3 <- FilePath -> FilePath -> Maybe FilePath
maybePrefixMatch FilePath
"}-#" (FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
s2)
        = Pragma -> Maybe Pragma
forall a. a -> Maybe a
Just (FilePath -> Pragma
Option (FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
s3))

        | Just FilePath
s1 <- FilePath -> FilePath -> Maybe FilePath
maybePrefixMatch FilePath
"{-#" FilePath
s, -- -}
          Just FilePath
s2 <- FilePath -> FilePath -> Maybe FilePath
maybePrefixMatch FilePath
"GLOBALOPTIONS" (FilePath -> FilePath
remove_spaces FilePath
s1),
          Just FilePath
s3 <- FilePath -> FilePath -> Maybe FilePath
maybePrefixMatch FilePath
"}-#" (FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
s2)
        = Pragma -> Maybe Pragma
forall a. a -> Maybe a
Just (FilePath -> Pragma
Global (FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
s3))

        | Bool
otherwise
        = Maybe Pragma
forall a. Maybe a
Nothing

remove_spaces :: String -> String
remove_spaces :: FilePath -> FilePath
remove_spaces = FilePath -> FilePath
forall a. [a] -> [a]
reverse (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
forall a. [a] -> [a]
reverse (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace

--
-- verbatim from utils\/Utils.lhs
--
prefixMatch :: Eq a => [a] -> [a] -> Bool
prefixMatch :: [a] -> [a] -> Bool
prefixMatch [] [a]
_str = Bool
True
prefixMatch [a]
_pat [] = Bool
False
prefixMatch (a
p:[a]
ps) (a
s:[a]
ss) | a
p a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
s    = [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
prefixMatch [a]
ps [a]
ss
                          | Bool
otherwise = Bool
False

maybePrefixMatch :: String -> String -> Maybe String
maybePrefixMatch :: FilePath -> FilePath -> Maybe FilePath
maybePrefixMatch []    FilePath
rest = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
rest
maybePrefixMatch (Char
_:FilePath
_) []   = Maybe FilePath
forall a. Maybe a
Nothing
maybePrefixMatch (Char
p:FilePath
pat) (Char
r:FilePath
rest)
        | Char
p Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
r    = FilePath -> FilePath -> Maybe FilePath
maybePrefixMatch FilePath
pat FilePath
rest
        | Bool
otherwise = Maybe FilePath
forall a. Maybe a
Nothing