<commit_before>{-# LANGUAGE CPP, OverloadedStrings #-}
{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
module Language.Hakaru.Parser.Maple where

import           Language.Hakaru.Parser.AST
import           Control.Monad.Identity
import           Data.Text           (Text)
import qualified Data.Text           as Text
#if __GLASGOW_HASKELL__ < 710
import           Data.Functor        ((<$>))
import           Control.Applicative (Applicative(..))
#endif
import           Text.Parsec
import           Text.Parsec.Text
import qualified Text.Parsec.Token   as Token
import           Text.Parsec.Language

style :: GenLanguageDef Text st Identity
style = Token.LanguageDef
    { Token.commentStart   = "(*"
    , Token.commentEnd     = "*)"
    , Token.commentLine    = "#"
    , Token.nestedComments = True
    , Token.identStart     = letter <|> char '_'
    , Token.identLetter    = alphaNum <|> oneOf "_"
    , Token.opStart        = Token.opLetter style
    , Token.opLetter       = oneOf "+-*/<>="
    , Token.reservedOpNames= []
    , Token.reservedNames  = []
    , Token.caseSensitive  = False
    }

symTable :: [(Text, Text)]
symTable =
    [ ("Gaussian", "normal")
    , ("BetaD",    "beta")
    , ("GammaD",   "gamma")
    , ("Weight",   "weight")
    , ("Msum",     "msum")
    , ("Uniform",  "uniform")
    , ("Ret",      "dirac")
    , ("True",     "true")
    , ("False",    "false")
    -- Type symbols
    , ("Real",     "real")
    , ("Prob",     "prob")
    , ("Measure",  "measure")
    , ("Pair",     "pair")
    , ("Bool",     "bool")
    ]

type TokenParser a = Token.GenTokenParser Text a Identity

data NumOp = Pos | Neg
    deriving (Eq, Show)

data ArgOp
    = Float | Power | Rational
    | Func  | ExpSeq
    deriving (Eq, Show)

data InertExpr
    = InertName Text
    | InertNum  NumOp Integer
    | InertArgs ArgOp [InertExpr]
    deriving (Eq, Show)

lexer :: TokenParser ()
lexer = Token.makeTokenParser style

integer :: Parser Integer
integer = Token.integer lexer

parens :: Parser a -> Parser a
parens = Token.parens lexer

identifier :: Parser Text
identifier = Text.pack <$> Token.identifier lexer

stringLiteral :: Parser Text
stringLiteral = Text.pack <$> Token.stringLiteral lexer

commaSep :: Parser a -> Parser [a]
commaSep = Token.commaSep lexer

arg :: Parser a -> Parser [a]
arg e = parens (commaSep e)

apply1 :: Parser a -> Parser a
apply1 e = do
    args <- arg e
    case args of
        [e'] -> return e'
        _    -> error "Expected only one argument"

apply2 :: Parser a -> Parser (a, a)
apply2 e = do
    args <- arg e
    case args of
        [e1, e2] -> return (e1, e2)
        _        -> error "Expected only two arguments"

text :: Text -> Parser Text
text = liftM Text.pack <$> string <$> Text.unpack

expr :: Parser InertExpr
expr =  try func
    <|> try name
    <|> try assignedname
    <|> try expseq
    <|> try intpos
    <|> try intneg
    <|> try power
    <|> try rational
    <|> float

func :: Parser InertExpr
func = InertArgs <$> (text "_Inert_FUNCTION" *> return Func) <*> arg expr

name :: Parser InertExpr
name = InertName <$> (text "_Inert_NAME" *> apply1 stringLiteral)

assignedname :: Parser InertExpr
assignedname = InertName <$> (text "_Inert_ASSIGNEDNAME" *> (fst <$> apply2 stringLiteral))

expseq :: Parser InertExpr
expseq = InertArgs <$> (text "_Inert_EXPSEQ" *> return ExpSeq) <*> arg expr

intpos :: Parser InertExpr
intpos = InertNum <$> (text "_Inert_INTPOS" *> return Pos) <*> apply1 integer

intneg :: Parser InertExpr
intneg = InertNum <$> (text "_Inert_INTNEG" *> return Neg) <*> fmap negate (apply1 integer)

float :: Parser InertExpr
float  = InertArgs <$> (text "_Inert_FLOAT" *> return Float) <*> arg expr

power :: Parser InertExpr
power = InertArgs <$> (text "_Inert_POWER" *> return Power) <*> arg expr

rational :: Parser InertExpr
rational = InertArgs <$> (text "_Inert_RATIONAL" *> return Rational) <*> arg expr

rename :: Text -> Text
rename x =
    case lookup x symTable of
    Just x' -> x'
    Nothing -> x

parseMaple :: Text -> Either ParseError InertExpr
parseMaple txt = runParser (expr <* eof) () (show txt) txt

maple2AST :: InertExpr -> AST' Text
maple2AST (InertNum Pos i) = ULiteral $ Nat $ fromInteger i
maple2AST (InertNum Neg i) = ULiteral $ Int $ fromInteger i

maple2AST (InertName t)    = Var (rename t)

maple2AST (InertArgs Float [InertNum Pos a, InertNum p b]) = 
    ULiteral $ Prob $ fromInteger a * (10 ** (fromInteger b))

maple2AST (InertArgs Float [InertNum Neg a, InertNum p b]) = 
    ULiteral $ Real $ fromInteger a * (10 ** (fromInteger b))

maple2AST (InertArgs Func [InertName "Ann", InertArgs ExpSeq [typ, e]]) =
    Ann (maple2AST e) (maple2Type typ)

maple2AST (InertArgs Func [InertName "Bind",
                           InertArgs ExpSeq [e1, InertName x, e2]]) =
    Bind x (maple2AST e1) (maple2AST e2)

maple2AST (InertArgs Func [f, (InertArgs ExpSeq a)]) =
    foldl App (maple2AST f) (map maple2AST a)
-- Add special case for NatPow for Power
maple2AST (InertArgs Power [x, y]) =
    App (App (Var "**") (maple2AST x)) (maple2AST y)
maple2AST (InertArgs Rational [InertNum _ x, InertNum _ y]) =
    ULiteral $ Real $ fromInteger x / fromInteger y

maple2AST x = error $ "Can't handle: " ++ show x
    
maple2Type :: InertExpr -> TypeAST'
-- TODO: Add Arrow
maple2Type (InertName t) = TypeVar (rename t)
maple2Type (InertArgs Func [InertName f, InertArgs ExpSeq args]) =
    TypeApp (rename f) (map maple2Type args)


<commit_msg>Add Msum as parsed form to Parser/Maple<commit_after>{-# LANGUAGE CPP, OverloadedStrings #-}
{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
module Language.Hakaru.Parser.Maple where

import           Language.Hakaru.Parser.AST
import           Control.Monad.Identity
import           Data.Text           (Text)
import qualified Data.Text           as Text
#if __GLASGOW_HASKELL__ < 710
import           Data.Functor        ((<$>))
import           Control.Applicative (Applicative(..))
#endif
import           Text.Parsec
import           Text.Parsec.Text
import qualified Text.Parsec.Token   as Token
import           Text.Parsec.Language

style :: GenLanguageDef Text st Identity
style = Token.LanguageDef
    { Token.commentStart   = "(*"
    , Token.commentEnd     = "*)"
    , Token.commentLine    = "#"
    , Token.nestedComments = True
    , Token.identStart     = letter <|> char '_'
    , Token.identLetter    = alphaNum <|> oneOf "_"
    , Token.opStart        = Token.opLetter style
    , Token.opLetter       = oneOf "+-*/<>="
    , Token.reservedOpNames= []
    , Token.reservedNames  = []
    , Token.caseSensitive  = False
    }

symTable :: [(Text, Text)]
symTable =
    [ ("Gaussian", "normal")
    , ("BetaD",    "beta")
    , ("GammaD",   "gamma")
    , ("Weight",   "weight")
    , ("Uniform",  "uniform")
    , ("Ret",      "dirac")
    , ("True",     "true")
    , ("False",    "false")
    -- Type symbols
    , ("Real",     "real")
    , ("Prob",     "prob")
    , ("Measure",  "measure")
    , ("Pair",     "pair")
    , ("Bool",     "bool")
    ]

type TokenParser a = Token.GenTokenParser Text a Identity

data NumOp = Pos | Neg
    deriving (Eq, Show)

data ArgOp
    = Float | Power | Rational
    | Func  | ExpSeq
    deriving (Eq, Show)

data InertExpr
    = InertName Text
    | InertNum  NumOp Integer
    | InertArgs ArgOp [InertExpr]
    deriving (Eq, Show)

lexer :: TokenParser ()
lexer = Token.makeTokenParser style

integer :: Parser Integer
integer = Token.integer lexer

parens :: Parser a -> Parser a
parens = Token.parens lexer

identifier :: Parser Text
identifier = Text.pack <$> Token.identifier lexer

stringLiteral :: Parser Text
stringLiteral = Text.pack <$> Token.stringLiteral lexer

commaSep :: Parser a -> Parser [a]
commaSep = Token.commaSep lexer

arg :: Parser a -> Parser [a]
arg e = parens (commaSep e)

apply1 :: Parser a -> Parser a
apply1 e = do
    args <- arg e
    case args of
        [e'] -> return e'
        _    -> error "Expected only one argument"

apply2 :: Parser a -> Parser (a, a)
apply2 e = do
    args <- arg e
    case args of
        [e1, e2] -> return (e1, e2)
        _        -> error "Expected only two arguments"

text :: Text -> Parser Text
text = liftM Text.pack <$> string <$> Text.unpack

expr :: Parser InertExpr
expr =  try func
    <|> try name
    <|> try assignedname
    <|> try expseq
    <|> try intpos
    <|> try intneg
    <|> try power
    <|> try rational
    <|> float

func :: Parser InertExpr
func = InertArgs <$> (text "_Inert_FUNCTION" *> return Func) <*> arg expr

name :: Parser InertExpr
name = InertName <$> (text "_Inert_NAME" *> apply1 stringLiteral)

assignedname :: Parser InertExpr
assignedname = InertName <$> (text "_Inert_ASSIGNEDNAME" *> (fst <$> apply2 stringLiteral))

expseq :: Parser InertExpr
expseq = InertArgs <$> (text "_Inert_EXPSEQ" *> return ExpSeq) <*> arg expr

intpos :: Parser InertExpr
intpos = InertNum <$> (text "_Inert_INTPOS" *> return Pos) <*> apply1 integer

intneg :: Parser InertExpr
intneg = InertNum <$> (text "_Inert_INTNEG" *> return Neg) <*> fmap negate (apply1 integer)

float :: Parser InertExpr
float  = InertArgs <$> (text "_Inert_FLOAT" *> return Float) <*> arg expr

power :: Parser InertExpr
power = InertArgs <$> (text "_Inert_POWER" *> return Power) <*> arg expr

rational :: Parser InertExpr
rational = InertArgs <$> (text "_Inert_RATIONAL" *> return Rational) <*> arg expr

rename :: Text -> Text
rename x =
    case lookup x symTable of
    Just x' -> x'
    Nothing -> x

parseMaple :: Text -> Either ParseError InertExpr
parseMaple txt = runParser (expr <* eof) () (show txt) txt

maple2AST :: InertExpr -> AST' Text
maple2AST (InertNum Pos i) = ULiteral $ Nat $ fromInteger i
maple2AST (InertNum Neg i) = ULiteral $ Int $ fromInteger i

maple2AST (InertName t)    = Var (rename t)

maple2AST (InertArgs Float [InertNum Pos a, InertNum p b]) = 
    ULiteral $ Prob $ fromInteger a * (10 ** (fromInteger b))

maple2AST (InertArgs Float [InertNum Neg a, InertNum p b]) = 
    ULiteral $ Real $ fromInteger a * (10 ** (fromInteger b))

maple2AST (InertArgs Func [InertName "Ann", InertArgs ExpSeq [typ, e]]) =
    Ann (maple2AST e) (maple2Type typ)

maple2AST (InertArgs Func [InertName "Bind",
                           InertArgs ExpSeq [e1, InertName x, e2]]) =
    Bind x (maple2AST e1) (maple2AST e2)

maple2AST (InertArgs Func [InertName "Bind",
                           InertArgs ExpSeq es]) =
    Msum (map maple2AST es)

maple2AST (InertArgs Func [f, (InertArgs ExpSeq a)]) =
    foldl App (maple2AST f) (map maple2AST a)
-- Add special case for NatPow for Power
maple2AST (InertArgs Power [x, y]) =
    App (App (Var "**") (maple2AST x)) (maple2AST y)
maple2AST (InertArgs Rational [InertNum _ x, InertNum _ y]) =
    ULiteral $ Real $ fromInteger x / fromInteger y

maple2AST x = error $ "Can't handle: " ++ show x
    
maple2Type :: InertExpr -> TypeAST'
-- TODO: Add Arrow
maple2Type (InertName t) = TypeVar (rename t)
maple2Type (InertArgs Func [InertName f, InertArgs ExpSeq args]) =
    TypeApp (rename f) (map maple2Type args)



{'fraction_non_alphanumeric': 0.12960621387283236, 'fraction_numerical': 0.008670520231213872, 'mean_word_length': 2.9210339943342776, 'pattern_counts': {'":': 0, '<': 77, '<?xml version=': 0, '>': 119, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3091587', 'n_tokens_mistral': 3912, 'n_tokens_neox': 3837, 'n_words': 1140}