freesect-0.8: FilesAndParsing.hs

--     Package:  freesect-0.8
-- Description:  Extend Haskell to support free sections
--     Example:  zipWith (f __ b __ d) as cs
--      Author:  Andrew Seniuk <rasfar@gmail.com>
--        Date:  March 11, 2012
--     License:  BSD3 (./LICENSE)
--  Executable:  freesect
--       Usage:  See accompanying files 000-readme and z

{-# LANGUAGE CPP #-}

-- CPP definitions are set using compiler options; see ./z and ./ile.

  module FilesAndParsing where

  import System.Directory(doesFileExist,
                          doesDirectoryExist,
                          getDirectoryContents,
                          getCurrentDirectory)

  import Data.Maybe(fromMaybe)

#if ANNOTATED
  import HSE.Annotated
#else
  import HSE
#endif

  import HSE.Extension


-- Code in this module is rather old, but has worked for me.
-- No doubt there are better libraries I should be using; will
-- fix this up for a subsequent release.

  readSourcesFromFileOrDir :: String -> IO [(String,String)]
  readSourcesFromFileOrDir pathname
   = do dfe <- doesFileExist pathname
        dde <- doesDirectoryExist pathname
        contents <- if dfe
                       then
                         do conts <- readFile pathname
                            return [(pathname,conts)]
                       else if dde
                               then readDirOfModules pathname
                               else error  $ "No such file or directory as "
                                          ++ pathname
        return contents

  -- if got here, the pathname exists and is a directory
  readDirOfModules :: String -> IO [(String,String)]
  readDirOfModules pathname
   = do
        dconts <- getDirectoryContents pathname
        cwd <- getCurrentDirectory
        let
          dconts' = filter isHS dconts
          pathname' = pathname ++ "/"
          dconts'' = map (pathname'++) dconts'
          dconts''' = map (removeDotPathComponent . makeAbsolute cwd) dconts''
        conts <- mapM readFile dconts'''
        return $ zip dconts''' conts

  -- XXX should also clean up ".." components...
  -- This function wasn't done to address any immediate problem
  -- but better to be clean.
  -- This is complicated by certain special cases,
  -- for instance if path was "/here/is./a/path".
  removeDotPathComponent :: String -> String
  removeDotPathComponent ('.':'.':'/':t) = error "path contained .."
  removeDotPathComponent ('.':'/':t) = removeDotPathComponent' t
  removeDotPathComponent x = removeDotPathComponent' x
  removeDotPathComponent' :: String -> String
  removeDotPathComponent' [] = []
  removeDotPathComponent' ('/':'.':'/':t) = removeDotPathComponent' ('/':t)
  removeDotPathComponent' ('/':'.':'.':'/':t) = error "path contained .."
  removeDotPathComponent' (h:t) = h : removeDotPathComponent' t

  makeAbsolute :: String -> String -> String
  makeAbsolute pfx pname
   | null pname         = ""
   | head pname == '/'  = pname  -- already absolute
   | otherwise          = pfx ++ "/" ++ pname

  isHS :: String -> Bool
  isHS s
   | length s < 4  = False
   | (take 3 $ reverse s) == "sh."  = True
   | otherwise = False

  testParses :: [ParseResult a] -> [a]
  testParses [] = []
  testParses (h:t)
   = ( case h of
         ParseOk x -> x
         ParseFailed x y -> error  $ "Parse error:\n" ++ " Location: "
                                  ++ show x ++ "\n Error: " ++ show y
     ) : testParses t

#if ANNOTATED
  doParsing :: [String] -> [String] -> [ParseResult (Module SrcSpanInfo)]
#else
  doParsing :: [String] -> [String] -> [ParseResult Module]
#endif
  doParsing [] _ = []
  doParsing (a:as) (b:bs)
   = (parseModuleWithMode (myParseMode a b) b) : doParsing as bs

  myParseMode :: String -> String -> ParseMode
  myParseMode fname lexsrc = ParseMode
    {parseFilename = fname
    ,extensions = theExtensions lexsrc
--  ,extensions = knownExtensions  -- or you can build explicit sublist
    ,ignoreLanguagePragmas = False
    ,ignoreLinePragmas = True
    ,fixities = Just baseFixities}

  theExtensions :: String -> [Extension]
  theExtensions lexsrc = e
   where
#if ANNOTATED
    e = fromMaybe [] $ readExtensions lexsrc
#else
    -- in retrospect, could probably have used readExtensions here, too?
    a = ( getTopPragmas lexsrc )   :: ParseResult [ModulePragma]
    [b] = ( testParses [a] )   :: [[ModulePragma]]
    c = ( concat ( map (\(LanguagePragma _ ns)->ns) b ) )   :: [Name]
    d = (map (\(Ident s)->s) c)   :: [String]
    e = ( map classifyExtension d )   :: [Extension]
#endif