egison-3.9.1: hs-src/Language/Egison/ParserNonS2.y
{
{-# OPTIONS -w #-}
{- |
Module : Language.Egison.ParserNonS2
Copyright : Satoshi Egi
Licence : MIT
This module provides new Egison parser.
-}
module Language.Egison.ParserNonS2
(
-- * Parse a string
readTopExprs
, readTopExpr
, readExprs
, readExpr
, parseTopExprs
, parseTopExpr
, parseExprs
, parseExpr
-- * Parse a file
, loadLibraryFile
, loadFile
) where
import Control.Monad.Except hiding (mapM)
import Data.Either
import qualified Data.Set as Set
import System.Directory (doesFileExist, getHomeDirectory)
import Language.Egison.Desugar
import Language.Egison.Lexer
import Language.Egison.Types
import Paths_egison (getDataFileName)
}
-- %name parseTopExprs_ TopExprs
%name parseTopExpr_ TopExpr
%name parseExpr_ Expr
%tokentype { Token }
%monad { Alex }
%lexer { lexwrap } { Token _ TokenEOF }
-- Without this we get a type error
%error { happyError }
%right '|'
%right "++"
%right "||"
%right "&&"
%right ':'
%left '<' '>' "==" "<=" ">="
%left '+' '-' '%'
%left '*' '/'
%left '^'
%right TENSOR
%token
True { Token _ TokenTrue }
False { Token _ TokenFalse }
test { Token _ TokenTest }
match { Token _ TokenMatch }
matchDFS { Token _ TokenMatchDFS }
matchAll { Token _ TokenMatchAll }
matchAllDFS { Token _ TokenMatchAllDFS }
matchLambda { Token _ TokenMatchLambda }
matchAllLambda { Token _ TokenMatchAllLambda }
as { Token _ TokenAs }
with { Token _ TokenWith }
something { Token _ TokenSomething }
if { Token _ TokenIf }
then { Token _ TokenThen }
else { Token _ TokenElse }
int { Token _ (TokenInt $$) }
var { Token _ (TokenVar $$) }
"==" { Token _ TokenEqEq }
'<' { Token _ TokenLT }
'>' { Token _ TokenGT }
"<=" { Token _ TokenLE }
">=" { Token _ TokenGE }
'+' { Token _ TokenPlus }
'-' { Token _ TokenMinus }
'%' { Token _ TokenPercent }
'*' { Token _ TokenAsterisk }
'/' { Token _ TokenDiv }
'^' { Token _ TokenCaret }
"&&" { Token _ TokenAndAnd }
"||" { Token _ TokenBarBar }
':' { Token _ TokenColon }
".." { Token _ TokenDotDot }
"++" { Token _ TokenPlusPlus }
'|' { Token _ TokenBar }
"->" { Token _ TokenArrow }
'$' { Token _ TokenDollar }
'_' { Token _ TokenUnderscore }
'#' { Token _ TokenSharp }
',' { Token _ TokenComma }
'\\' { Token _ TokenBackSlash }
"*$" { Token _ TokenAstDollar }
'=' { Token _ TokenEq }
'(' { Token _ TokenLParen }
')' { Token _ TokenRParen }
'[' { Token _ TokenLBracket }
']' { Token _ TokenRBracket }
%%
-- TopExprs :
-- TopExpr { [$1] }
-- | TopExpr TopExprs { $1 : $2 }
TopExpr :: { EgisonTopExpr }
: var '=' Expr { Define (stringToVar $1) $3 }
| var list1(Arg) '=' Expr { Define (stringToVar $1) (LambdaExpr $2 $4) }
| Expr { Test $1 }
| test '(' Expr ')' { Test $3 }
Expr :: { EgisonExpr }
: Expr1 { $1 }
| MatchExpr { $1 }
| '\\' list1(Arg) "->" Expr { LambdaExpr $2 $4 }
| if Expr then Expr else Expr { IfExpr $2 $4 $6 }
Expr1 :: { EgisonExpr }
: Atoms { $1 }
| '-' Atom { makeApply (VarExpr $ stringToVar "*") [IntegerExpr(-1), $2] }
| BinOpExpr { $1 }
BinOpExpr :: { EgisonExpr }
: Expr1 "==" Expr1 { makeApply (VarExpr $ stringToVar "eq?") [$1, $3] }
| Expr1 "<=" Expr1 { makeApply (VarExpr $ stringToVar "lte?") [$1, $3] }
| Expr1 '<' Expr1 { makeApply (VarExpr $ stringToVar "lt?") [$1, $3] }
| Expr1 ">=" Expr1 { makeApply (VarExpr $ stringToVar "gte?") [$1, $3] }
| Expr1 '>' Expr1 { makeApply (VarExpr $ stringToVar "gt?") [$1, $3] }
| Expr1 '+' Expr1 { makeApply (VarExpr $ stringToVar "+") [$1, $3] }
| Expr1 '-' Expr1 { makeApply (VarExpr $ stringToVar "-") [$1, $3] }
| Expr1 '%' Expr1 { makeApply (VarExpr $ stringToVar "remainder") [$1, $3] }
| Expr1 '*' Expr1 { makeApply (VarExpr $ stringToVar "*") [$1, $3] }
| Expr1 '/' Expr1 { makeApply (VarExpr $ stringToVar "/") [$1, $3] }
| Expr1 '^' Expr1 { makeApply (VarExpr $ stringToVar "**") [$1, $3] }
| Expr1 "&&" Expr1 { makeApply (VarExpr $ stringToVar "and") [$1, $3] }
| Expr1 "||" Expr1 { makeApply (VarExpr $ stringToVar "or") [$1, $3] }
| Expr1 ':' Expr1 { makeApply (VarExpr $ stringToVar "cons") [$1, $3] }
| Expr1 "++" Expr1 { makeApply (VarExpr $ stringToVar "append") [$1, $3] }
Atoms :: { EgisonExpr }
: Atom { $1 }
| Atom list1(Atom) { makeApply $1 $2 }
MatchExpr :: { EgisonExpr }
: match Expr as Expr with '|' MatchClauses { MatchExpr $2 $4 $7 }
| matchDFS Expr as Expr with '|' MatchClauses { MatchDFSExpr $2 $4 $7 }
| matchAll Expr as Expr with '|' MatchClauses { MatchAllExpr $2 $4 $7 }
| matchAllDFS Expr as Expr with '|' MatchClauses { MatchAllDFSExpr $2 $4 $7 }
| matchLambda as Expr with '|' MatchClauses { MatchLambdaExpr $3 $6 }
| matchAllLambda as Expr with '|' MatchClauses { MatchAllLambdaExpr $3 $6 }
MatchClauses :: { [MatchClause] }
: Pattern "->" Expr { [($1, $3)] }
| MatchClauses '|' Pattern "->" Expr { $1 ++ [($3, $5)] }
-- FIXME :
-- Uncommenting these 2 rules will yield shift/reduce conflict at
-- TopExpr -> var . '=' Expr
-- TopExpr -> var . list1__Arg__ '=' Expr
-- Atom -> var .
Arg :: { Arg }
: '$' var { ScalarArg $2 }
-- | var { ScalarArg $1 }
| "*$" var { InvertedScalarArg $2 }
-- | '%' var %prec TENSOR { TensorArg $2 }
Atom :: { EgisonExpr }
: int { IntegerExpr $1 }
| var { VarExpr $ stringToVar $1 }
| True { BoolExpr True }
| False { BoolExpr False }
| something { SomethingExpr }
| '(' sep2(Expr, ',') ')' { TupleExpr $2 }
| '[' sep(Expr, ',') ']' { CollectionExpr (map ElementExpr $2) }
| '(' Expr ')' { $2 }
| '[' Expr ".." Expr ']' { makeApply (VarExpr $ stringToVar "between") [$2, $4] }
--
-- Patterns
--
Pattern :: { EgisonPattern }
: '_' { WildCard }
| '$' var { PatVar (stringToVar $2) }
| '#' Atom { ValuePat $2 }
| '(' sep2(Pattern, ',') ')' { TuplePat $2 }
| Pattern ':' Pattern { InductivePat "cons" [$1, $3] }
| Pattern "++" Pattern { InductivePat "join" [$1, $3] }
--
-- Helpers (Parameterized Products)
--
sep2(p, q) : p q sep1(p, q) { $1 : $3 }
sep1(p, q) : p list(snd(q, p)) { $1 : $2 }
sep(p, q) : sep1(p, q) { $1 }
| { [] }
snd(p, q) : p q { $2 }
list1(p) : rev_list1(p) { reverse $1 }
list(p) : list1(p) { $1 }
| { [] }
rev_list1(p) : p { [$1] }
| rev_list1(p) p { $2 : $1 }
{
makeApply :: EgisonExpr -> [EgisonExpr] -> EgisonExpr
makeApply func xs = do
let args = map (\x -> case x of
LambdaArgExpr s -> Left s
_ -> Right x) xs
let vars = lefts args
case vars of
[] -> ApplyExpr func . TupleExpr $ rights args
_ | all null vars ->
let args' = rights args
args'' = zipWith (curry f) args (annonVars 1 (length args))
args''' = map (VarExpr . stringToVar . either id id) args''
in ApplyExpr (LambdaExpr (map ScalarArg (rights args'')) (LambdaExpr (map ScalarArg (lefts args'')) $ ApplyExpr func $ TupleExpr args''')) $ TupleExpr args'
| all (not . null) vars ->
let n = Set.size $ Set.fromList vars
args' = rights args
args'' = zipWith (curry g) args (annonVars (n + 1) (length args))
args''' = map (VarExpr . stringToVar . either id id) args''
in ApplyExpr (LambdaExpr (map ScalarArg (rights args'')) (LambdaExpr (map ScalarArg (annonVars 1 n)) $ ApplyExpr func $ TupleExpr args''')) $ TupleExpr args'
where
annonVars m n = take n $ map ((':':) . show) [m..]
f (Left _, var) = Left var
f (Right _, var) = Right var
g (Left arg, _) = Left (':':arg)
g (Right _, var) = Right var
lexwrap :: (Token -> Alex a) -> Alex a
lexwrap = (alexMonadScan' >>=)
happyError :: Token -> Alex a
happyError (Token _ TokenEOF) = alexError "unexpected end of input"
happyError (Token p t) = alexError' p ("parse error at token '" ++ show t ++ "'")
readTopExprs :: String -> EgisonM [EgisonTopExpr]
readTopExprs = either throwError (mapM desugarTopExpr) . parseTopExprs
readTopExpr :: String -> EgisonM EgisonTopExpr
readTopExpr = either throwError desugarTopExpr . parseTopExpr
readExprs :: String -> EgisonM [EgisonExpr]
readExprs = liftEgisonM . runDesugarM . either throwError (mapM desugar) . parseExprs
readExpr :: String -> EgisonM EgisonExpr
readExpr = liftEgisonM . runDesugarM . either throwError desugar . parseExpr
parseTopExprs :: String -> Either EgisonError [EgisonTopExpr]
parseTopExprs = undefined -- runAlex' parseTopExprs_
parseTopExpr :: String -> Either EgisonError EgisonTopExpr
parseTopExpr = runAlex' parseTopExpr_
parseExprs :: String -> Either EgisonError [EgisonExpr]
parseExprs = undefined
parseExpr :: String -> Either EgisonError EgisonExpr
parseExpr = runAlex' parseExpr_
-- |Load a libary file
loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr]
loadLibraryFile file = do
homeDir <- liftIO getHomeDirectory
doesExist <- liftIO $ doesFileExist $ homeDir ++ "/.egison/" ++ file
if doesExist
then loadFile $ homeDir ++ "/.egison/" ++ file
else liftIO (getDataFileName file) >>= loadFile
-- |Load a file
loadFile :: FilePath -> EgisonM [EgisonTopExpr]
loadFile file = do
doesExist <- liftIO $ doesFileExist file
unless doesExist $ throwError $ Default ("file does not exist: " ++ file)
input <- liftIO $ readUTF8File file
exprs <- readTopExprs $ shebang input
concat <$> mapM recursiveLoad exprs
where
recursiveLoad (Load file) = loadLibraryFile file
recursiveLoad (LoadFile file) = loadFile file
recursiveLoad expr = return [expr]
shebang :: String -> String
shebang ('#':'!':cs) = ';':'#':'!':cs
shebang cs = cs
}