ehaskell-0.7: EHaskell.hs

module EHaskell (
  mkEhsSrc
) where

import Data.Char                       (isSpace, isAlphaNum)
import Data.Bool.Tools                 ((|||))
import Control.Monad.Tools             (skipRet)
import Text.ParserCombinators.MTLParse (Parse, runParse, spot, token, tokens,
                                        mplus, list, neList, optional,
					endOfInput, still,
					parseNot)
import Types       (CodeText(..))
import MkCode      (arrangeCode, mkSrcText, mkSrcCode,
                    mkSrcBegin, mkSrcCont, mkSrcEnd,
		    mkSrcImport, mkSrcDefinition, mkSrcTop,
		    mkSrcEq, mkSrcEqEq, mkSrcEqShow, mkSrcEqEqShow)
import GetCodeText (getCodeText)

data CodePos = Import     { getModName :: String } | Top   |
               Definition { getVar :: String }     | Inner
  deriving (Eq, Show)
isImport, isDefinition :: CodePos -> Bool
isImport (Import _)         = True
isImport _                  = False
isDefinition (Definition _) = True
isDefinition _              = False

mkEhsSrc :: [ (String, String) ] -> String -> (String, [String])
mkEhsSrc defs src
  = let posSrcPair = fst $ myHead $ runParse parsePairAll ([], getCodeText src)
        importSrc  = concat $ mLookupBy isImport posSrcPair
	defSrc     = concat (map snd $ deleteDef (map fst defs) posSrcPair) ++
	             unlines (map (\(var, val) -> var ++ " = " ++ val) defs)
	topSrc     = concat $ mLookup Top posSrcPair
        innerSrc   = concat $ mLookup Inner posSrcPair
	mods       = map getModName $ filter isImport $ map fst posSrcPair
     in (arrangeCode (importSrc ++ defSrc ++ topSrc) innerSrc, mods)
  where myHead (h:_) = h
        myHead _     = error "parsePairAll in EHaskellNew module: parse error"

deleteDef :: [ String ] -> [ (CodePos, String) ] -> [ (CodePos, String) ]
deleteDef vars pairs = filter (flip notElem vars . getVar . fst) $
                       filter (isDefinition . fst ) pairs

parsePairAll, parsePair :: Parse (CodeText, String) [ (CodePos, String) ]
parsePairAll
  = parsePair >>= endOfInput
parsePair
  = fmap concat $ list $ parsePairText   `mplus` parsePairCode     `mplus`
                         parsePairTop    `mplus` parsePairApply    `mplus`
			 parsePairEq     `mplus` parsePairEqEq     `mplus`
			 parsePairEqShow `mplus` parsePairEqEqShow

parsePairText, parsePairCode, parsePairTop, parsePairApply,
  parsePairEq, parsePairEqEq, parsePairEqShow, parsePairEqEqShow
  :: Parse (CodeText, String) [ (CodePos, String) ]
parsePairText = do
  (_, src) <- spot ((==Text).fst)
  return [ (Inner, mkSrcText src) ]
parsePairCode = do
  (_, src) <- spot ((==Code).fst)
  return [ (Inner, mkSrcCode src) ]
parsePairTop = do
  (_, src) <- spot ((==CodeTop).fst)
  return [ makeIDT src ]
parsePairApply = do
  (_, srcB) <- spot ((==CodeBegin).fst)
  pcf       <- parsePair
  pcs       <- fmap concat $ list $ do
    (_, srcC) <- spot ((==CodeCont).fst)
    pcsGen    <- parsePair
    return $ (Inner, mkSrcCont srcC) : pcsGen
  (_, srcE) <- spot ((==CodeEnd).fst)
  return $ (Inner, mkSrcBegin srcB) : pcf ++ pcs ++ [ (Inner, mkSrcEnd srcE) ]
parsePairEq = do
  (_, src) <- spot ((==CodeEq).fst)
  return $ [ (Inner, mkSrcEq src) ]
parsePairEqShow = do
  (_, src) <- spot ((==CodeEqShow).fst)
  return $ [ (Inner, mkSrcEqShow src) ]
parsePairEqEq = do
  (_, src) <- spot ((==CodeEqEq).fst)
  return $ [ (Inner, mkSrcEqEq src) ]
parsePairEqEqShow = do
  (_, src) <- spot ((==CodeEqEqShow).fst)
  return $ [ (Inner, mkSrcEqEqShow src) ]

makeIDT :: String -> ( CodePos, String )
makeIDT = fst . myHead . runParse parseIDT . (,) ""
  where myHead (h:_) = h
        myHead _     = error "parseIDT in EHaskellNew: parse error"

parseIDT, parseImport, parseDefinition, parseTop
  :: Parse Char ( CodePos, String )
parseIDT    = parseImport `mplus` parseDefinition `mplus` parseTop
parseImport = do
  list $ spot isSpace
  tokens "import"
  neList $ spot isSpace
  mdl  <- list $ spot $ isAlphaNum ||| flip elem "."
  imps <- fmap concat $ optional $ do
    list $ spot isSpace
    token '('
    list (spot $ const True) >>= skipRet (token ')')
  list $ spot isSpace
  endOfInput ()
  return (Import mdl, mkSrcImport mdl imps)
parseDefinition = do
  list $ spot isSpace
  var <- list (spot isVarChar) >>= skipRet (still $ spot $ not . isVarChar)
  list $ spot isSpace
  token '=' >> still (spot $ not . isSymbol)
  list $ spot isSpace
  val <- list (spot $ const True) >>= endOfInput
  return (Definition var, mkSrcDefinition var val)
  where
  isVarChar = isAlphaNum ||| flip elem "_"
  isSymbol  = flip elem "!#$%&*+./<=>?@\\^|-~"
parseTop = do
  still $ parseNot () $ parseImport `mplus` parseDefinition
  list (spot isSpace) >> still (spot $ not . isSpace)
  src <- list (spot $ const True) >>= endOfInput
  return (Top, mkSrcTop src)

mLookup :: Eq a => a -> [ (a, b) ] -> [ b ]
mLookup x ps = map snd $ filter ((x==).fst) ps

mLookupBy :: (a -> Bool) -> [ (a, b) ] -> [ b ]
mLookupBy p ps = map snd $ filter (p . fst) ps