{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NamedFieldPuns #-}
module Language.Egison.ParserNonS
(
readTopExprs
, readTopExpr
, readExprs
, readExpr
, parseTopExprs
, parseTopExpr
, parseExprs
, parseExpr
, loadLibraryFile
, loadFile
) where
import Control.Applicative (pure, (*>), (<$>), (<$), (<*), (<*>))
import Control.Monad.Except (liftIO, throwError)
import Control.Monad.State (evalStateT, get, put, StateT, unless)
import Data.Char (isAsciiUpper, isLetter)
import Data.Either (isRight)
import Data.Functor (($>))
import Data.List (find, groupBy, insertBy)
import Data.Maybe (fromJust, isJust, isNothing)
import Data.Text (pack)
import Control.Monad.Combinators.Expr
import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import Text.Megaparsec.Pos (Pos)
import System.Directory (doesFileExist, getHomeDirectory)
import System.IO
import Language.Egison.AST
import Language.Egison.Desugar
import Language.Egison.Data
import Paths_egison (getDataFileName)
readTopExprs :: String -> EgisonM [EgisonTopExpr]
readTopExprs = either throwError (mapM desugarTopExpr) . parseTopExprs
readTopExpr :: String -> EgisonM EgisonTopExpr
readTopExpr = either throwError desugarTopExpr . parseTopExpr
readExprs :: String -> EgisonM [EgisonExpr]
readExprs = either throwError (mapM desugarExpr) . parseExprs
readExpr :: String -> EgisonM EgisonExpr
readExpr = either throwError desugarExpr . parseExpr
parseTopExprs :: String -> Either EgisonError [EgisonTopExpr]
parseTopExprs = doParse $ many (L.nonIndented sc topExpr) <* eof
parseTopExpr :: String -> Either EgisonError EgisonTopExpr
parseTopExpr = doParse $ sc >> topExpr <* eof
parseExprs :: String -> Either EgisonError [EgisonExpr]
parseExprs = doParse $ many (L.nonIndented sc expr) <* eof
parseExpr :: String -> Either EgisonError EgisonExpr
parseExpr = doParse $ sc >> expr <* eof
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
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
readUTF8File :: FilePath -> IO String
readUTF8File name = do
h <- openFile name ReadMode
hSetEncoding h utf8
hGetContents h
type Parser = StateT PState (Parsec CustomError String)
data PState
= PState { exprInfix :: [Infix]
, patternInfix :: [Infix]
}
initialPState :: PState
initialPState = PState { exprInfix = reservedExprInfix
, patternInfix = reservedPatternInfix
}
data CustomError
= IllFormedSection Infix Infix
| IllFormedDefine
deriving (Eq, Ord)
instance ShowErrorComponent CustomError where
showErrorComponent (IllFormedSection op op') =
"The operator " ++ info op ++ " must have lower precedence than " ++ info op'
where
info op =
"'" ++ repr op ++ "' [" ++ show (assoc op) ++ " " ++ show (priority op) ++ "]"
showErrorComponent IllFormedDefine =
"Failed to parse the left hand side of definition expression."
doParse :: Parser a -> String -> Either EgisonError a
doParse p input =
case parse (evalStateT p initialPState) "egison" input of
Left e -> throwError (Parser (errorBundlePretty e))
Right r -> return r
topExpr :: Parser EgisonTopExpr
topExpr = Load <$> (reserved "load" >> stringLiteral)
<|> LoadFile <$> (reserved "loadFile" >> stringLiteral)
<|> infixExpr
<|> defineOrTestExpr
<?> "toplevel expression"
data ConversionResult
= Variable Var
| Function Var [Arg]
| IndexedVar VarWithIndices
addNewOp :: Infix -> Bool -> Parser ()
addNewOp newop isPattern = do
pstate <- get
put $! if isPattern
then pstate { patternInfix = insertBy
(\x y -> compare (priority y) (priority x))
newop
(patternInfix pstate) }
else pstate { exprInfix = insertBy
(\x y -> compare (priority y) (priority x))
newop
(exprInfix pstate) }
infixExpr :: Parser EgisonTopExpr
infixExpr = do
assoc <- (reserved "infixl" $> LeftAssoc)
<|> (reserved "infixr" $> RightAssoc)
<|> (reserved "infix" $> NonAssoc)
isPattern <- isRight <$> eitherP (reserved "expression") (reserved "pattern")
priority <- fromInteger <$> positiveIntegerLiteral
sym <- if isPattern then newPatOp >>= checkP else some opChar >>= check
let newop = Infix { repr = sym, func = sym, priority, assoc, isWedge = False }
addNewOp newop isPattern
return (InfixDecl isPattern newop)
where
check :: String -> Parser String
check ('!':_) = fail $ "cannot declare infix starting with '!'"
check x | x `elem` reservedOp = fail $ show x ++ " cannot be a new infix"
| otherwise = return x
checkP :: String -> Parser String
checkP x | x `elem` reservedPOp = fail $ show x ++ " cannot be a new pattern infix"
| otherwise = return x
reservedOp = [":", ":=", "->"]
reservedPOp = ["&", "|", ":=", "->"]
defineOrTestExpr :: Parser EgisonTopExpr
defineOrTestExpr = do
e <- expr
defineExpr e <|> return (Test e)
where
defineExpr :: EgisonExpr -> Parser EgisonTopExpr
defineExpr e = do
_ <- symbol ":="
case convertToDefine e of
Nothing -> customFailure IllFormedDefine
Just (Variable var) -> Define var <$> expr
Just (Function var args) -> Define var . LambdaExpr args <$> expr
Just (IndexedVar var) -> DefineWithIndices var <$> expr
convertToDefine :: EgisonExpr -> Maybe ConversionResult
convertToDefine (VarExpr var) = return $ Variable var
convertToDefine (ApplyExpr (VarExpr var) (TupleExpr args)) = do
args' <- mapM ((ScalarArg <$>) . exprToStr) args
return $ Function var args'
convertToDefine (ApplyExpr (SectionExpr op Nothing Nothing) (TupleExpr [x, y])) = do
args <- mapM ((ScalarArg <$>) . exprToStr) [x, y]
return $ Function (stringToVar (repr op)) args
convertToDefine e@(BinaryOpExpr op _ _)
| repr op == "*" || repr op == "%" || repr op == "$" = do
args <- exprToArgs e
case args of
ScalarArg var : args -> return $ Function (Var [var] []) args
_ -> Nothing
convertToDefine (IndexedExpr True (VarExpr (Var var [])) indices) = do
indices' <- mapM (traverse exprToStr) indices
return $ IndexedVar (VarWithIndices var indices')
convertToDefine _ = Nothing
exprToStr :: EgisonExpr -> Maybe String
exprToStr (VarExpr (Var [x] [])) = Just x
exprToStr _ = Nothing
exprToArgs :: EgisonExpr -> Maybe [Arg]
exprToArgs (VarExpr (Var [x] [])) = return [ScalarArg x]
exprToArgs (ApplyExpr func (TupleExpr args)) =
(++) <$> exprToArgs func <*> mapM ((ScalarArg <$>) . exprToStr) args
exprToArgs (SectionExpr op Nothing Nothing) = return [ScalarArg (repr op)]
exprToArgs (BinaryOpExpr op lhs rhs) | repr op == "*" = do
lhs' <- exprToArgs lhs
rhs' <- exprToArgs rhs
case rhs' of
ScalarArg x : xs -> return (lhs' ++ InvertedScalarArg x : xs)
_ -> Nothing
exprToArgs (BinaryOpExpr op lhs rhs) | repr op == "%" = do
lhs' <- exprToArgs lhs
rhs' <- exprToArgs rhs
case rhs' of
ScalarArg x : xs -> return (lhs' ++ TensorArg x : xs)
_ -> Nothing
exprToArgs (BinaryOpExpr op lhs rhs) | repr op == "$" = do
lhs' <- exprToArgs lhs
rhs' <- exprToArgs rhs
case rhs' of
ScalarArg _ : _ -> return (lhs' ++ rhs')
_ -> Nothing
exprToArgs _ = Nothing
expr :: Parser EgisonExpr
expr = do
body <- exprWithoutWhere
bindings <- optional (reserved "where" >> alignSome binding)
return $ case bindings of
Nothing -> body
Just bindings -> LetRecExpr bindings body
exprWithoutWhere :: Parser EgisonExpr
exprWithoutWhere =
ifExpr
<|> patternMatchExpr
<|> lambdaExpr
<|> lambdaLikeExpr
<|> letExpr
<|> withSymbolsExpr
<|> doExpr
<|> ioExpr
<|> capplyExpr
<|> matcherExpr
<|> algebraicDataMatcherExpr
<|> arrayOpExpr
<|> tensorExpr
<|> tensorOpExpr
<|> functionExpr
<|> refsExpr
<|> opExpr
<?> "expression"
opExpr :: Parser EgisonExpr
opExpr = do
infixes <- exprInfix <$> get
makeExprParser atomOrApplyExpr (makeExprTable infixes)
makeExprTable :: [Infix] -> [[Operator Parser EgisonExpr]]
makeExprTable infixes =
let prefixes = [ [ Prefix (unary "-")
, Prefix (unary "!") ] ]
infixes' = map (map toOperator)
(groupBy (\x y -> priority x == priority y) infixes)
in prefixes ++ infixes'
where
unary :: String -> Parser (EgisonExpr -> EgisonExpr)
unary sym = UnaryOpExpr <$> try (operator sym <* notFollowedBy (symbol ")"))
binary :: Infix -> Parser (EgisonExpr -> EgisonExpr -> EgisonExpr)
binary op = do
op <- try (indented >> infixLiteral (repr op) <* notFollowedBy (symbol ")"))
return $ BinaryOpExpr op
toOperator :: Infix -> Operator Parser EgisonExpr
toOperator = infixToOperator binary
ifExpr :: Parser EgisonExpr
ifExpr = reserved "if" >> IfExpr <$> expr <* reserved "then" <*> expr <* reserved "else" <*> expr
patternMatchExpr :: Parser EgisonExpr
patternMatchExpr = makeMatchExpr (reserved "match") (MatchExpr BFSMode)
<|> makeMatchExpr (reserved "matchDFS") (MatchExpr DFSMode)
<|> makeMatchExpr (reserved "matchAll") (MatchAllExpr BFSMode)
<|> makeMatchExpr (reserved "matchAllDFS") (MatchAllExpr DFSMode)
<?> "pattern match expression"
where
makeMatchExpr keyword ctor = ctor <$> (keyword >> expr)
<*> (reserved "as" >> expr)
<*> (reserved "with" >> matchClauses1)
matchClauses1 :: Parser [MatchClause]
matchClauses1 =
(lookAhead (symbol "|") >> alignSome matchClause) <|> (:[]) <$> matchClauseWithoutBar
where
matchClauseWithoutBar :: Parser MatchClause
matchClauseWithoutBar = (,) <$> pattern <*> (symbol "->" >> expr)
matchClause :: Parser MatchClause
matchClause = (,) <$> (symbol "|" >> pattern) <*> (symbol "->" >> expr)
lambdaExpr :: Parser EgisonExpr
lambdaExpr = symbol "\\" >> (
makeMatchLambdaExpr (reserved "match") MatchLambdaExpr
<|> makeMatchLambdaExpr (reserved "matchAll") MatchAllLambdaExpr
<|> try (LambdaExpr <$> some arg <* symbol "->") <*> expr
<|> PatternFunctionExpr <$> some lowerId <*> (symbol "=>" >> pattern))
<?> "lambda or pattern function expression"
where
makeMatchLambdaExpr keyword ctor = do
matcher <- keyword >> reserved "as" >> expr
clauses <- reserved "with" >> matchClauses1
return $ ctor matcher clauses
lambdaLikeExpr :: Parser EgisonExpr
lambdaLikeExpr =
(reserved "memoizedLambda" >> MemoizedLambdaExpr <$> many lowerId <*> (symbol "->" >> expr))
<|> (reserved "procedure" >> ProcedureExpr <$> many lowerId <*> (symbol "->" >> expr))
<|> (reserved "cambda" >> CambdaExpr <$> lowerId <*> (symbol "->" >> expr))
arg :: Parser Arg
arg = InvertedScalarArg <$> (char '*' >> ident)
<|> TensorArg <$> (char '%' >> ident)
<|> ScalarArg <$> (char '$' >> ident)
<|> ScalarArg <$> ident
<?> "argument"
letExpr :: Parser EgisonExpr
letExpr = do
binds <- reserved "let" >> oneLiner <|> alignSome binding
body <- reserved "in" >> expr
return $ LetRecExpr binds body
where
oneLiner :: Parser [BindingExpr]
oneLiner = braces $ sepBy binding (symbol ";")
binding :: Parser BindingExpr
binding = do
(vars, args) <- (,[]) <$> parens (sepBy varLiteral comma)
<|> do var <- varLiteral
args <- many arg
return ([var], args)
body <- symbol ":=" >> expr
return $ case args of
[] -> (vars, body)
_ -> (vars, LambdaExpr args body)
withSymbolsExpr :: Parser EgisonExpr
withSymbolsExpr = WithSymbolsExpr <$> (reserved "withSymbols" >> brackets (sepBy ident comma)) <*> expr
doExpr :: Parser EgisonExpr
doExpr = do
stmts <- reserved "do" >> oneLiner <|> alignSome statement
return $ case last stmts of
([], retExpr@(ApplyExpr (VarExpr (Var ["return"] _)) _)) ->
DoExpr (init stmts) retExpr
_ -> DoExpr stmts (makeApply' "return" [])
where
statement :: Parser BindingExpr
statement = (reserved "let" >> binding) <|> ([],) <$> expr
oneLiner :: Parser [BindingExpr]
oneLiner = braces $ sepBy statement (symbol ";")
ioExpr :: Parser EgisonExpr
ioExpr = IoExpr <$> (reserved "io" >> expr)
capplyExpr :: Parser EgisonExpr
capplyExpr = CApplyExpr <$> (reserved "capply" >> atomExpr) <*> atomExpr
matcherExpr :: Parser EgisonExpr
matcherExpr = do
reserved "matcher"
MatcherExpr <$> alignSome (symbol "|" >> patternDef)
where
patternDef :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])
patternDef = do
pp <- ppPattern
returnMatcher <- reserved "as" >> expr <* reserved "with"
datapat <- alignSome (symbol "|" >> dataCases)
return (pp, returnMatcher, datapat)
dataCases :: Parser (PrimitiveDataPattern, EgisonExpr)
dataCases = (,) <$> pdPattern <*> (symbol "->" >> expr)
algebraicDataMatcherExpr :: Parser EgisonExpr
algebraicDataMatcherExpr = do
reserved "algebraicDataMatcher"
AlgebraicDataMatcherExpr <$> alignSome (symbol "|" >> patternDef)
where
patternDef = indentBlock lowerId atomExpr
arrayOpExpr :: Parser EgisonExpr
arrayOpExpr =
(reserved "generateArray" >> GenerateArrayExpr <$> atomExpr <*> arrayShape)
<|> (reserved "arrayBounds" >> ArrayBoundsExpr <$> atomExpr)
<|> (reserved "arrayRef" >> ArrayRefExpr <$> atomExpr <*> atomExpr)
where
arrayShape :: Parser (EgisonExpr, EgisonExpr)
arrayShape = parens $ (,) <$> expr <*> (comma >> expr)
tensorExpr :: Parser EgisonExpr
tensorExpr = TensorExpr <$> (reserved "tensor" >> atomExpr) <*> atomExpr
tensorOpExpr :: Parser EgisonExpr
tensorOpExpr =
(reserved "generateTensor" >> GenerateTensorExpr <$> atomExpr <*> atomExpr)
<|> (reserved "contract" >> TensorContractExpr <$> atomExpr <*> atomExpr)
<|> (reserved "tensorMap" >> TensorMapExpr <$> atomExpr <*> atomExpr)
<|> (reserved "tensorMap2" >> TensorMap2Expr <$> atomExpr <*> atomExpr <*> atomExpr)
<|> (reserved "transpose" >> TransposeExpr <$> atomExpr <*> atomExpr)
functionExpr :: Parser EgisonExpr
functionExpr = FunctionExpr <$> (reserved "function" >> parens (sepBy expr comma))
refsExpr :: Parser EgisonExpr
refsExpr =
(reserved "subrefs" >> SubrefsExpr False <$> atomExpr <*> atomExpr)
<|> (reserved "subrefs!" >> SubrefsExpr True <$> atomExpr <*> atomExpr)
<|> (reserved "suprefs" >> SuprefsExpr False <$> atomExpr <*> atomExpr)
<|> (reserved "suprefs!" >> SuprefsExpr True <$> atomExpr <*> atomExpr)
<|> (reserved "userRefs" >> UserrefsExpr False <$> atomExpr <*> atomExpr)
<|> (reserved "userRefs!" >> UserrefsExpr True <$> atomExpr <*> atomExpr)
collectionExpr :: Parser EgisonExpr
collectionExpr = symbol "[" >> betweenOrFromExpr <|> elementsExpr
where
betweenOrFromExpr = do
start <- try (expr <* symbol "..")
end <- optional expr <* symbol "]"
case end of
Just end' -> return $ makeApply' "between" [start, end']
Nothing -> return $ makeApply' "from" [start]
elementsExpr = CollectionExpr <$> (sepBy (ElementExpr <$> expr) comma <* symbol "]")
tupleOrParenExpr :: Parser EgisonExpr
tupleOrParenExpr = do
elems <- symbol "(" >> try (sepBy expr comma <* symbol ")") <|> (section <* symbol ")")
case elems of
[x] -> return x
_ -> return $ TupleExpr elems
where
section :: Parser [EgisonExpr]
section = (:[]) <$> (rightSection <|> leftSection)
leftSection :: Parser EgisonExpr
leftSection = do
infixes <- exprInfix <$> get
op <- choice $ map (infixLiteral . repr) infixes
rarg <- optional expr
case rarg of
Just (BinaryOpExpr op' _ _)
| assoc op' /= RightAssoc && priority op >= priority op' ->
customFailure (IllFormedSection op op')
_ -> return (SectionExpr op Nothing rarg)
rightSection :: Parser EgisonExpr
rightSection = do
infixes <- exprInfix <$> get
larg <- opExpr
op <- choice $ map (infixLiteral . repr) infixes
case larg of
BinaryOpExpr op' _ _
| assoc op' /= LeftAssoc && priority op >= priority op' ->
customFailure (IllFormedSection op op')
_ -> return (SectionExpr op (Just larg) Nothing)
arrayExpr :: Parser EgisonExpr
arrayExpr = ArrayExpr <$> between (symbol "(|") (symbol "|)") (sepEndBy expr comma)
vectorExpr :: Parser EgisonExpr
vectorExpr = VectorExpr <$> between (symbol "[|") (symbol "|]") (sepEndBy expr comma)
hashExpr :: Parser EgisonExpr
hashExpr = HashExpr <$> hashBraces (sepEndBy hashElem comma)
where
hashBraces = between (symbol "{|") (symbol "|}")
hashElem = parens $ (,) <$> expr <*> (comma >> expr)
index :: Parser (Index EgisonExpr)
index = SupSubscript <$> (string "~_" >> atomExpr')
<|> try (char '_' >> subscript)
<|> try (char '~' >> superscript)
<|> try (Userscript <$> (char '|' >> atomExpr'))
<?> "index"
where
subscript = do
e1 <- atomExpr'
e2 <- optional (string "..._" >> atomExpr')
case e2 of
Nothing -> return $ Subscript e1
Just e2' -> return $ MultiSubscript e1 e2'
superscript = do
e1 <- atomExpr'
e2 <- optional (string "...~" >> atomExpr')
case e2 of
Nothing -> return $ Superscript e1
Just e2' -> return $ MultiSuperscript e1 e2'
atomOrApplyExpr :: Parser EgisonExpr
atomOrApplyExpr = do
(func, args) <- indentBlock atomExpr atomExpr
return $ case args of
[] -> func
_ -> makeApply func args
atomExpr :: Parser EgisonExpr
atomExpr = do
e <- atomExpr'
override <- isNothing <$> optional (try (string "..." <* lookAhead index))
indices <- many index
return $ case indices of
[] -> e
_ -> IndexedExpr override e indices
atomExpr' :: Parser EgisonExpr
atomExpr' = partialExpr
<|> constantExpr
<|> FreshVarExpr <$ symbol "#"
<|> VarExpr <$> varLiteral
<|> vectorExpr
<|> arrayExpr
<|> collectionExpr
<|> tupleOrParenExpr
<|> hashExpr
<|> QuoteExpr <$> (char '\'' >> atomExpr')
<|> QuoteSymbolExpr <$> (char '`' >> atomExpr')
<|> PartialVarExpr <$> try (char '%' >> positiveIntegerLiteral)
<?> "atomic expression"
partialExpr :: Parser EgisonExpr
partialExpr = do
n <- try (L.decimal <* char '#')
body <- atomExpr
return $ PartialExpr n body
constantExpr :: Parser EgisonExpr
constantExpr = numericExpr
<|> BoolExpr <$> boolLiteral
<|> CharExpr <$> try charLiteral
<|> StringExpr . pack <$> stringLiteral
<|> SomethingExpr <$ reserved "something"
<|> UndefinedExpr <$ reserved "undefined"
numericExpr :: Parser EgisonExpr
numericExpr = FloatExpr <$> try positiveFloatLiteral
<|> IntegerExpr <$> positiveIntegerLiteral
<?> "numeric expression"
pattern :: Parser EgisonPattern
pattern = letPattern
<|> forallPattern
<|> loopPattern
<|> opPattern
<?> "pattern"
letPattern :: Parser EgisonPattern
letPattern =
reserved "let" >> LetPat <$> alignSome binding <*> (reserved "in" >> pattern)
forallPattern :: Parser EgisonPattern
forallPattern =
reserved "forall" >> ForallPat <$> atomPattern <*> atomPattern
loopPattern :: Parser EgisonPattern
loopPattern =
LoopPat <$> (reserved "loop" >> patVarLiteral) <*> loopRange
<*> atomPattern <*> atomPattern
where
loopRange :: Parser LoopRange
loopRange =
parens $ do start <- expr
ends <- option (defaultEnds start) (try $ comma >> expr)
as <- option WildCard (comma >> pattern)
return $ LoopRange start ends as
defaultEnds s =
ApplyExpr (stringToVarExpr "from")
(makeApply (stringToVarExpr "-'") [s, IntegerExpr 1])
seqPattern :: Parser EgisonPattern
seqPattern = do
pats <- braces $ sepBy pattern comma
return $ foldr SeqConsPat SeqNilPat pats
opPattern :: Parser EgisonPattern
opPattern = do
ops <- patternInfix <$> get
makeExprParser applyOrAtomPattern (makePatternTable ops)
makePatternTable :: [Infix] -> [[Operator Parser EgisonPattern]]
makePatternTable ops =
let infixes = map toOperator ops
in map (map snd) (groupBy (\x y -> fst x == fst y) infixes)
where
toOperator :: Infix -> (Int, Operator Parser EgisonPattern)
toOperator op = (priority op, infixToOperator binary op)
binary :: Infix -> Parser (EgisonPattern -> EgisonPattern -> EgisonPattern)
binary op = do
op <- try (indented >> patInfixLiteral (repr op))
return $ InfixPat op
applyOrAtomPattern :: Parser EgisonPattern
applyOrAtomPattern = (do
(func, args) <- indentBlock (try atomPattern) atomPattern
case (func, args) of
(_, []) -> return func
(InductivePat x [], _) -> return $ InductiveOrPApplyPat x args
_ -> fail $ "Pattern not understood: " ++ show (func, args))
<|> (do
(func, args) <- indentBlock atomExpr atomPattern
return $ PApplyPat func args)
atomPattern :: Parser EgisonPattern
atomPattern = do
pat <- atomPattern'
indices <- many . try $ char '_' >> atomExpr'
return $ case indices of
[] -> pat
_ -> IndexedPat pat indices
atomPattern' :: Parser EgisonPattern
atomPattern' = WildCard <$ symbol "_"
<|> PatVar <$> patVarLiteral
<|> NotPat <$> (symbol "!" >> atomPattern)
<|> ValuePat <$> (char '#' >> atomExpr)
<|> InductivePat "nil" [] <$ (symbol "[" >> symbol "]")
<|> InductivePat <$> lowerId <*> pure []
<|> VarPat <$> (char '~' >> lowerId)
<|> PredPat <$> (symbol "?" >> atomExpr)
<|> ContPat <$ symbol "..."
<|> makeTupleOrParen pattern TuplePat
<|> seqPattern
<|> LaterPatVar <$ symbol "@"
<?> "atomic pattern"
ppPattern :: Parser PrimitivePatPattern
ppPattern = PPInductivePat <$> lowerId <*> many ppAtom
<|> do ops <- patternInfix <$> get
makeExprParser ppAtom (makeTable ops)
<?> "primitive pattern pattern"
where
makeTable :: [Infix] -> [[Operator Parser PrimitivePatPattern]]
makeTable ops =
map (map toOperator) (groupBy (\x y -> priority x == priority y) ops)
toOperator :: Infix -> Operator Parser PrimitivePatPattern
toOperator = infixToOperator inductive2
inductive2 op = (\x y -> PPInductivePat (func op) [x, y]) <$ operator (repr op)
ppAtom :: Parser PrimitivePatPattern
ppAtom = PPWildCard <$ symbol "_"
<|> PPPatVar <$ symbol "$"
<|> PPValuePat <$> (string "#$" >> lowerId)
<|> PPInductivePat "nil" [] <$ (symbol "[" >> symbol "]")
<|> makeTupleOrParen ppPattern PPTuplePat
pdPattern :: Parser PrimitiveDataPattern
pdPattern = PDInductivePat <$> upperId <*> many pdAtom
<|> PDSnocPat <$> (symbol "snoc" >> pdAtom) <*> pdAtom
<|> makeExprParser pdAtom table
<?> "primitive data pattern"
where
table :: [[Operator Parser PrimitiveDataPattern]]
table =
[ [ InfixR (PDConsPat <$ symbol "::") ]
]
pdAtom :: Parser PrimitiveDataPattern
pdAtom = PDWildCard <$ symbol "_"
<|> PDPatVar <$> (char '$' >> lowerId)
<|> PDConstantPat <$> constantExpr
<|> PDEmptyPat <$ (symbol "[" >> symbol "]")
<|> makeTupleOrParen pdPattern PDTuplePat
sc :: Parser ()
sc = L.space space1 lineCmnt blockCmnt
where
lineCmnt = L.skipLineComment "--"
blockCmnt = L.skipBlockCommentNested "{-" "-}"
lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc
positiveIntegerLiteral :: Parser Integer
positiveIntegerLiteral = lexeme L.decimal
<?> "unsinged integer"
charLiteral :: Parser Char
charLiteral = between (char '\'') (symbol "\'") L.charLiteral
<?> "character"
stringLiteral :: Parser String
stringLiteral = char '\"' *> manyTill L.charLiteral (symbol "\"")
<?> "string"
boolLiteral :: Parser Bool
boolLiteral = reserved "True" $> True
<|> reserved "False" $> False
<?> "boolean"
positiveFloatLiteral :: Parser Double
positiveFloatLiteral = lexeme L.float
<?> "unsigned float"
varLiteral :: Parser Var
varLiteral = stringToVar <$> ident
patVarLiteral :: Parser Var
patVarLiteral = stringToVar <$> (char '$' >> lowerId)
infixLiteral :: String -> Parser Infix
infixLiteral sym =
try (do wedge <- optional (char '!')
opSym <- operator' sym
infixes <- exprInfix <$> get
let opInfo = fromJust $ find ((== opSym) . repr) infixes
return $ opInfo { isWedge = isJust wedge })
<?> "infix"
where
operator' :: String -> Parser String
operator' sym = string sym <* notFollowedBy opChar <* sc
reserved :: String -> Parser ()
reserved w = (lexeme . try) (string w *> notFollowedBy identChar)
symbol :: String -> Parser ()
symbol sym = try (L.symbol sc sym) >> pure ()
operator :: String -> Parser String
operator sym = try $ string sym <* notFollowedBy opChar <* sc
patInfixLiteral :: String -> Parser Infix
patInfixLiteral sym =
try (do opSym <- string sym <* notFollowedBy patOpChar <* sc
infixes <- patternInfix <$> get
let opInfo = fromJust $ find ((== opSym) . repr) infixes
return opInfo)
opChar :: Parser Char
opChar = oneOf ("%^&*-+\\|:<>.?!/'#@$" ++ "∧")
patOpChar :: Parser Char
patOpChar = oneOf "%^&*-+\\|:<>./'"
newPatOp :: Parser String
newPatOp = (:) <$> patOpChar <*> many (patOpChar <|> oneOf "!?#@$")
identChar :: Parser Char
identChar = alphaNumChar
<|> oneOf (['?', '\'', '/'] ++ mathSymbols)
<|> try (char '.' <* notFollowedBy (char '.'))
mathSymbols :: String
mathSymbols = "∂∇"
parens :: Parser a -> Parser a
parens = between (symbol "(") (symbol ")")
braces :: Parser a -> Parser a
braces = between (symbol "{") (symbol "}")
brackets :: Parser a -> Parser a
brackets = between (symbol "[") (symbol "]")
comma :: Parser ()
comma = symbol ","
lowerId :: Parser String
lowerId = (lexeme . try) (p >>= check)
where
p = (:) <$> satisfy (\c -> c `elem` mathSymbols || isLetter c && not (isAsciiUpper c)) <*> many identChar
check x = if x `elem` lowerReservedWords
then fail $ "keyword " ++ show x ++ " cannot be an identifier"
else return x
upperId :: Parser String
upperId = (lexeme . try) (p >>= check)
where
p = (:) <$> satisfy isAsciiUpper <*> many alphaNumChar
check x = if x `elem` upperReservedWords
then fail $ "keyword " ++ show x ++ " cannot be an identifier"
else return x
ident :: Parser String
ident = (lexeme . try) (p >>= check)
where
p = (:) <$> satisfy (\c -> c `elem` mathSymbols || isLetter c) <*> many identChar
check x = if x `elem` (lowerReservedWords ++ upperReservedWords)
then fail $ "keyword " ++ show x ++ " cannot be an identifier"
else return x
upperReservedWords :: [String]
upperReservedWords =
[ "True"
, "False"
]
lowerReservedWords :: [String]
lowerReservedWords =
[ "loadFile"
, "load"
, "if"
, "then"
, "else"
, "capply"
, "memoizedLambda"
, "cambda"
, "procedure"
, "let"
, "in"
, "where"
, "withSymbols"
, "loop"
, "forall"
, "match"
, "matchDFS"
, "matchAll"
, "matchAllDFS"
, "as"
, "with"
, "matcher"
, "do"
, "io"
, "something"
, "undefined"
, "algebraicDataMatcher"
, "generateArray"
, "arrayBounds"
, "arrayRef"
, "generateTensor"
, "tensor"
, "contract"
, "tensorMap"
, "tensorMap2"
, "transpose"
, "subrefs"
, "subrefs!"
, "suprefs"
, "suprefs!"
, "userRefs"
, "userRefs!"
, "function"
, "infixl"
, "infixr"
, "infix"
]
makeTupleOrParen :: Parser a -> ([a] -> a) -> Parser a
makeTupleOrParen parser tupleCtor = do
elems <- parens $ sepBy parser comma
case elems of
[elem] -> return elem
_ -> return $ tupleCtor elems
makeApply :: EgisonExpr -> [EgisonExpr] -> EgisonExpr
makeApply (InductiveDataExpr x []) xs = InductiveDataExpr x xs
makeApply func xs = ApplyExpr func (TupleExpr xs)
makeApply' :: String -> [EgisonExpr] -> EgisonExpr
makeApply' func xs = ApplyExpr (stringToVarExpr func) (TupleExpr xs)
indentGuardEQ :: Pos -> Parser Pos
indentGuardEQ pos = L.indentGuard sc EQ pos
indentGuardGT :: Pos -> Parser Pos
indentGuardGT pos = L.indentGuard sc GT pos
alignSome :: Parser a -> Parser [a]
alignSome p = do
pos <- L.indentLevel
some (indentGuardEQ pos >> p)
indentBlock :: Parser a -> Parser b -> Parser (a, [b])
indentBlock phead parg = do
pos <- L.indentLevel
head <- phead
args <- many (indentGuardGT pos >> parg)
return (head, args)
indented :: Parser Pos
indented = indentGuardGT pos1
infixToOperator :: (Infix -> Parser (a -> a -> a)) -> Infix -> Operator Parser a
infixToOperator opToParser op =
case assoc op of
LeftAssoc -> InfixL (opToParser op)
RightAssoc -> InfixR (opToParser op)
NonAssoc -> InfixN (opToParser op)