freesect-0.8: Util.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 Util where

  import Data.Generics.Aliases(mkQ)
  import Data.Generics.Schemes(everything)
--import Data.Generics  -- this suffices to import both the above

  import System.Random(StdGen,mkStdGen,next)

  import Data.List(isPrefixOf)

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

--------------------------------------------------------------------------------

#if ANNOTATED
  stripFSPragma (Module x1 x2 prags x4 x5)
   = Module x1 x2 prags' x4 x5
#else
  stripFSPragma (Module x1 x2 prags x4 x5 x6 x7)
   = Module x1 x2 prags' x4 x5 x6 x7
#endif
   where prags' = map f prags
         f (LanguagePragma sl_or_ssi ns)
          = LanguagePragma sl_or_ssi $ filter p ns
         f x = x
#if ANNOTATED
         p n@(Ident sl_or_ssi "FreeSections") = False
#else
         p n@(Ident           "FreeSections") = False
#endif
         p _ = True

#if ANNOTATED
  stripEmptyPragmaList (Module x1 x2 prags x4 x5)
   = Module x1 x2 prags' x4 x5
#else
  stripEmptyPragmaList (Module x1 x2 prags x4 x5 x6 x7)
   = Module x1 x2 prags' x4 x5 x6 x7
#endif
   where prags' = filter p prags
         p (LanguagePragma ssi []) = False
         p _ = True

#if ANNOTATED
  fixModuleName name (Module x1 x2 x3 x4 x5)
   = Module x1 name' x3 x4 x5
#else
  fixModuleName name (Module x1 x2 x3 x4 x5 x6 x7)
   = Module x1 name' x3 x4 x5 x6 x7
#endif
   where
#if ANNOTATED
         (Just (ModuleHead ssi _ mwt mesl)) = x2
         name' = Just (ModuleHead ssi (ModuleName ssi name) mwt mesl)
#else
         (ModuleName _) = x2
         name' = ModuleName name
#endif
         p (LanguagePragma ssi []) = False
         p _ = True

--------------------------------------------------------------------------------

  -- The names which FreeSect inserts will never conflict with each other.
  -- We only need to assure they don't conflict with any existing names.
  -- Actually, we need to make sure the name created here is not a prefix
  -- of any existing name, because we add _XY to freesect slot names.
#if ANNOTATED
  fs_fresh_name :: Module SrcSpanInfo -> String  -- nec. (since refactoring?)
#else
  fs_fresh_name :: Module -> String  -- nec. (since refactoring?)
#endif
  fs_fresh_name m = f g
   where
         ss = fs_all_identifiers m
         g = mkStdGen 123  -- arbitrary seed
         -- The following was much simpler when accept whole of r
         -- as the random part of the name -- however, that made for
         -- ugly long names, and so we try for the shortest possible
         -- first.  (If you never inspect the intermediate code, you
         -- wouldn't care if the var names were ugly...)
         f :: StdGen -> String
         f g | b          = s
             | otherwise  = f g'  -- unlikely
             where (r,g') = next g
                   (b,s) = f' rs (0,length rs)
                   rs = show r
         f' :: String -> (Int,Int) -> (Bool,String)
         f' s (n,ntop) | n > ntop   = (False,"")
                       | not fail   = (True,s'')
                       | otherwise  = f' s (1+n,ntop)
                       where s' = take n s
                             s'' =         s' ++ "_"
--                           s'' = "fs" ++ s' ++ "_"
                             fail = or $ map (isPrefixOf s'') ss

--fs_all_identifiers :: Data a => a -> [String]
  fs_all_identifiers = everything (++) ([] `mkQ` f)
   where
#if ANNOTATED
         f :: Name SrcSpanInfo -> [String]  -- seems nec.
#else
--       f :: Name -> [String]  -- unnec.
#endif
#if ANNOTATED
         f (Ident _ x) = [x]
#else
         f (Ident x) = [x]
#endif
         f _ = []