Parser.hs

{-# LANGUAGE TypeFamilies, CPP #-}
module Math.FreeModule.Parser where

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

import Control.Monad
import Text.ParserCombinators.Parsec

import Math.FreeModule.Class
import Math.FreeModule.Symbol

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

type Par s a = GenParser Char s a

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

-- | Parses @\"alpha[5]\"@ style symbols
symbolP :: Par s Symbol
symbolP = do
  n <- many1 alphaNum
  i <- option Nothing $ do
    char '['
    xs <- many1 digit
    char ']'
    return $ Just (read xs :: Int)
  return (Symbol n i)
  
-- | Parses @\"e2\"@ style symbols
symbolP' :: Par s Symbol
symbolP' = do
  n <- many1 letter
  i <- option Nothing $ do
    xs <- many1 digit
    return $ Just (read xs :: Int)
  return (Symbol n i)

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

integerP :: Par s Integer
integerP = do
  s <- option 1 signP
  xs <- many1 digit
  return $ s * (read xs)
  
--------------------------------------------------------------------------------

signP :: Num a => Par s a 
signP = do
  c <- oneOf "+-"
  return $ case c of { '+' -> 1 ; '-' -> (-1) }

betweenSpaces :: Par s a -> Par s a
betweenSpaces p = do
  spaces
  x <- p
  spaces
  return x  

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

notEmpty :: GenParser tok st a -> GenParser tok st a
notEmpty parser = do
  pos1 <- getPosition
  x <- parser
  pos2 <- getPosition
  if (pos1 == pos2)
    then fail "empty"
    else return x

-- this is useful for exterior algebras, for example. 
freeModuleP' :: FreeModule a => Par s (Base a,Coeff a) -> Par s (Coeff a) -> Par s a
freeModuleP' baseP coeffP = try p <|> q where
  p = betweenSpaces (string "0") >> eof >> return zero
  q = liftM fromList $ do
    xs <- liftM helper $ many1 (termP baseP coeffP) 
    spaces
    eof
    return xs
  helper = map $ \((b,c1),c2) -> (b,c1*c2)
    
freeModuleP :: FreeModule a => Par s (Base a) -> Par s (Coeff a) -> Par s a
freeModuleP baseP coeffP = try p <|> q where
  p = betweenSpaces (string "0") >> eof >> return zero
  q = liftM fromList $ do
    xs <- many1 (termP baseP coeffP) 
    spaces
    eof
    return xs
    
termP :: Num c => Par s b -> Par s c -> Par s (b,c)
termP baseP coeffP = 
  do
    s <- option 1 (betweenSpaces signP)  
    (b,c) <- try q <|> p
    return (b,s*c)
  where 
    p = do
      b <- notEmpty baseP  
      return (b,1)
    q = do
      c <- coeffP
      optional (betweenSpaces (char '*'))
      b <- baseP  
      return (b,c)
{-
  s <- option 1 (betweenSpaces signP)  
  c <- option 1 $ do
    c <- coeffP
    optional (betweenSpaces (char '*'))
    return c
  b <- baseP  
  return (b,s*c)
-}  

--------------------------------------------------------------------------------
  
parseLinearExpr :: (FreeModule a, Base a ~ Symbol, Coeff a ~ Integer) => String -> a
parseLinearExpr = parseFreeModule symbolP integerP

parseFreeModule :: FreeModule a => Parser (Base a) -> Parser (Coeff a) -> String -> a
parseFreeModule baseP coeffP s =
  case runParser p () "input" s of
    Left err -> error (show err)
    Right x  -> x
  where 
    p = freeModuleP baseP coeffP
  
--------------------------------------------------------------------------------