ChaseImports.hs revision edf0b87513720db0373e96424c4ad7b50e54299c
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder{- this module coordinates the whole shebang.
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder First splits input into `of interest' and `computer generated'
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder Then parses 'of interest', and plucks out data and newtype declarations and
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder processor commands
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder The commands are combined with the parsed data, and if any data is missing,
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder derive goes hunting for it, looking in likely script and interface files in
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder the path variable DERIVEPATH. Derive searches recusively though modules
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder imported until all the types needed are found, or it runs out of links,
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder which causes an error -}
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maedermodule ChaseImports where
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maederimport RuleUtils (Tag)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maederimport CommandP
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maederimport ParseLib2
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maederimport qualified Literate
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder-- #if defined(__HASKELL98__)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder-- #define FMAP fmap
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder-- import IO (try)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder-- #define FMAP map
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder-- #if defined(__HUGS__)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder-- import IO (try)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder-- #elif defined(__GLASGOW_HASKELL__)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder-- import IOBase (tryIO)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder-- try = tryIO
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder-- #elif defined(__NHC__) || defined(__HBC__)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maedertry x = catch (x >>= return . Right) (return . Left)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder--- Split up input ---------------------------------------------------------
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaedersplitString :: String -> String -> (String,String)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaedersplitString s = (\(x,y) -> (unlines x,unlines y)) .
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder break (\x -> x == s || x == '>':s)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaederuserCode = splitString codeSeperator
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaedercodeSeperator = "{-* Generated by DrIFT : Look, but Don't Touch. *-}"
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder-- Parser - extract data and newtypes from code
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maedertype ToDo = [([Tag],Data)]
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maederparser :: String -> ToDo
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maederparser = sanitycheck . papply p (0,0) . \s -> ((0,0),s)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder p = parse . skipUntilOff $ statement +++ command
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder statement = do d <- datadecl +++ newtypedecl
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder ts <- opt local
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder return (ts,d)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder sanitycheck [] = error "***Error: no DrIFT directives found\n"
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder sanitycheck [(x,_)] = x
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder sanitycheck ((x,_):_) = error "***Error: ambiguous DriFT directives?"
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaederimportParser :: String -> [Data]
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaederimportParser text = fst . head . papply p (0,-1) $ ((0,0),ip)
2eb84fc82d3ffa9116bc471fda3742bd9e5a24bbChristian Maeder ip = snd $ splitString "_declarations_" text
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder p = parse $ skipUntilParse ';' info
2eb84fc82d3ffa9116bc471fda3742bd9e5a24bbChristian Maeder info = do integer
2eb84fc82d3ffa9116bc471fda3742bd9e5a24bbChristian Maeder (datadecl+++newtypedecl)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder-------Go Hunting for files, recursively ----------------------------------
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaederchaseImports :: String -> ToDo -> IO ToDo
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaederchaseImports txt dats = do
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder (left,found) <- chaseImports' txt dats
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder if (not . null) left then error ("can't find type " ++ show left)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder else return found
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaederchaseImports' :: String -> ToDo -> IO (ToDo,ToDo)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaederchaseImports' text dats =
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder case papply (parse header) (0,-1) ((0,0),text) of
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder [] -> return (dats,[])
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder (modnames:_) -> foldM action (dats,[]) (fst modnames)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder action :: (ToDo,ToDo) -> FilePath -> IO (ToDo,ToDo)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder action (dats,done) m | null dats = return ([],done)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder | otherwise = do
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder paths <- fmap breakPaths (getEnv "DERIVEPATH")
020928b46741d7f6cf2ef9d5a2359dafd9a28f73Wiebke Herding -- may want a few more envs here ...
020928b46741d7f6cf2ef9d5a2359dafd9a28f73Wiebke Herding c <- findModule paths m
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder let (found,rest) = scanModule dats c
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder if (null rest) then return ([],done ++ found) -- finished
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder else do (dats',done') <- chaseImports' c rest
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder return (dats',done' ++ done ++ found)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder-- break DERIVEPATH into it's components
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaederbreakPaths :: String -> [String]
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaederbreakPaths x = case break (==':') x of
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder (p,(_:pp)) -> p: breakPaths pp
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder (p,[]) -> [p]
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder-- search though paths, using try
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaederfindModule :: [String] -> String -> IO String
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaederfindModule paths modname = let
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder action p = try $ do h <- readFile p
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder fnames = combine paths modname ++ combine paths hiracle_modname
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder hiracle_modname = map (\x -> if x == '.' then '/' else x) modname
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder isLeft (Left _ ) = True
afbd86903151121381e4e9d22862136817d7f0f0Christian Maeder isLeft _ = False
afbd86903151121381e4e9d22862136817d7f0f0Christian Maeder hh <- mapM action fnames
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder let (h,p) = case dropWhile (isLeft) hh of
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder ((Right ff):_) -> ff
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder _ -> error ("can't find module " ++ modname)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder --putStrLn ("-- " ++ p)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder return $ fromLit (isLiterate p) h
afbd86903151121381e4e9d22862136817d7f0f0Christian Maeder-- generate filepaths by combining module names with different suffixes.
afbd86903151121381e4e9d22862136817d7f0f0Christian Maeder-- Note : Dedicated Hugs-only users may wish to remove ".hi" from the list of
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder-- file types to search.
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maedercombine :: [String] -> String -> [FilePath]
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maedercombine paths modname = [p++'/':f| f <- toFile modname, p <- ("." :paths)]
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder toFile :: String -> [String]
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder toFile l = [l++".hs",l++".lhs",l++".hi"]
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder-- pluck out the bits of interest
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaederscanModule :: ToDo -> String -> (ToDo,ToDo)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaederscanModule dats txt = let
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder newDats = filter isData . parse $ txt
afbd86903151121381e4e9d22862136817d7f0f0Christian Maeder parse l = case head ( words l) of
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder "_interface_" -> importParser $ l
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder _ -> map snd . parser . fst . userCode $ l
afbd86903151121381e4e9d22862136817d7f0f0Christian Maeder in (resolve newDats dats ([],[]))
afbd86903151121381e4e9d22862136817d7f0f0Christian Maeder-- update what's still missing
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maederresolve :: [Data] -> ToDo -> (ToDo,ToDo) -> (ToDo,ToDo)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maederresolve _ [] acc = acc
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maederresolve parsed ((tags,TypeName t):tt) (local,imports) =
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder case filter ((== t) . name) parsed of
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder [x] -> resolve parsed tt ((tags,x):local,imports)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder _ -> resolve parsed tt (local,(tags,TypeName t):imports)
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder--handle literate scripts ---------------------------------------------------
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder-- NB we don't do the latex-style literate scripts currently.
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaederfromLit True txt = case Literate.process txt of
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder (e,_) -> error e
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaederfromLit False txt = txt
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaedertoLit True = unlines . map (\l -> '>':l) . lines
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaedertoLit False = id
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaederisLiterate :: String -> Bool
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaederisLiterate fname = ".lhs" `isSuffixOf` fname
9929f81562adecc8aafaefb14a0159afcf4a3351Christian Maeder-- utils -- this should be the sort of thing automatically generated !!
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaederisData D{} = True
9929f81562adecc8aafaefb14a0159afcf4a3351Christian MaederisData _ = False