zwirn-0.2.2.1: src/zwirn-lang/Zwirn/Language/Parser.y
{
module Zwirn.Language.Parser
( parseSyntaxWithPos
, parseSyntax
, parseTermWithPos
, parseTerm
, parseBlocks
, parseScheme
) where
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromJust)
import Data.Monoid (First (..))
import Data.List (intercalate, sortOn)
import qualified Zwirn.Language.Lexer as L
import Zwirn.Language.Syntax
import Zwirn.Language.TypeCheck.Types
import Zwirn.Language.TypeCheck.Infer
import Zwirn.Language.Block
import Zwirn.Language.Location
{-
Parser.hs - parser for zwirn, code adapted from
https://serokell.io/blog/parsing-with-happy
Copyright (C) 2025, Martin Gius
This library is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library. IfTok not, see <http://www.gnu.org/licenses/>.
-}
}
%name pTerm term
%name pSyntax syntax
%name pBlocks blocks
%name pScheme scheme
%tokentype { L.Lexeme }
%errorhandlertype explist
%error { parseError }
%monad { L.Alex } { >>= } { pure }
%lexer { lexer } { Located _ L.EOF }
%expect 0
%token
-- Keywords
if { Located _ L.IfTok }
then { Located _ L.ThenTok }
else { Located _ L.ElseTok }
-- IdentifierToks
identifier { Located _ (L.IdentifierTok _) }
-- OperatorToks
operator { Located _ (L.OperatorTok _) }
specop { Located _ (L.SpecialOperatorTok _) }
-- Constants
string { Located _ (L.TextTok _) }
number { Located _ (L.NumberTok _) }
macro { Located _ (L.MacroTok _) }
flag { Located _ (L.CompilerFlagTok _) }
line { Located _ (L.LineTok _) }
bsep { Located _ (L.BlockSepTok) }
'~' { Located _ L.RestTok }
'_' { Located _ L.UnderscoreTok }
-- Repeat
'!' { Located _ L.RepeatTok }
repnum { Located _ (L.RepeatNumberTok _) }
-- Parenthesis
'(' { Located _ L.LParTok }
')' { Located _ L.RParTok }
-- Sequences
'[' { Located _ L.LBrackTok }
']' { Located _ L.RBrackTok }
-- Stacks
',' { Located _ L.CommaTok }
-- Alternations
'<' { Located _ L.LAngleTok }
'>' { Located _ L.RAngleTok }
-- Choice
'|' { Located _ L.ChoiceTok }
-- EnumTok
'..' { Located _ L.EnumTok }
-- PolyTokrhythm
'%' { Located _ L.PolyTok }
-- LambdaTok
'\\' { Located _ L.LambdaTok }
'->' { Located _ L.ArrowTok }
-- Definitions
'=' { Located _ L.DefineTok }
'<-' { Located _ L.DynamicDefineTok }
-- Actions
':t' { Located _ L.TypeCommandTok }
':show' { Located _ L.ShowCommandTok }
':config' { Located _ L.ShowConfigCommandTok }
':resetconfig' { Located _ L.ResetShowConfigCommandTok }
':load' { Located _ (L.LoadCommandTok _ ) }
':info' { Located _ L.InfoCommandTok }
':reset' { Located _ L.ResetEnvCommandTok }
':set' { Located _ L.SetCommandTok }
':status' { Located _ L.StatusCommandTok }
':env' { Located _ L.EnvCommandTok }
-- Type Tokens
'=>' { Located _ L.TypeContextTok }
textT { Located _ L.TextTypeTok }
numT { Located _ L.NumberTypeTok }
mapT { Located _ L.MapTypeTok }
actionT { Located _ L.ActionTypeTok }
varT { Located _ (L.VarTypeTok _) }
classT { Located _ (L.TypeClassTok _) }
%%
-------------------------------------------------------------
------------------------- utilities -------------------------
-------------------------------------------------------------
optional(p)
: { Nothing }
| p { Just $1 }
many_rev(p)
: { [] }
| many_rev(p) p { $2 : $1 }
many(p)
: many_rev(p) { reverse $1 }
some_rev(p)
: p { [$1] }
| some_rev(p) p { $2 : $1 }
some(p)
: some_rev(p) { reverse $1 }
sepBy_rev(p, sep)
: p { [$1] }
| sepBy_rev(p, sep) sep p { $3 : $1 }
sepBy(p, sep)
: sepBy_rev(p, sep) { reverse $1 }
sepBy_rev2(p, sep)
: p sep p { [$3, $1] }
| sepBy_rev2(p, sep) sep p { $3 : $1 }
sepBy2(p, sep)
: sepBy_rev2(p, sep) { reverse $1 }
-------------------------------------------------------------
----------------------- parsing terms -----------------------
-------------------------------------------------------------
atom :: { LocTerm }
: identifier { (mkAtom TVar) $1 }
| '(' operator ')' { (mkAtom TVar) $2 }
| '(' specop ')' { (mkAtom TVar) $2 }
| number { (mkAtom TNum) $1 }
| string { (mkAtom TText) $1 }
| macro { (mkAtom TMacro) $1 }
| '~' { Located (lLoc $1) TRest }
simpleseq :: { [LocTerm] }
: infix %shift { [$1] }
| infix simpleseq { $1:$2 }
seq :: { LocTerm }
: simpleseq { mergeManyWith TSeq $1 }
| infix '..' infix { Located ($1 <-> $3) $ (TEnum Run) $1 $3 }
| infix infix '..' infix { Located ($1 <-> $4) $ (TEnumThen Run) $1 $2 $4 }
sequence :: { LocTerm }
: '[' seq ']' { mapLoc (const ($1 <-> $3)) $2 }
| '[' ']' { Located ($1 <-> $2) TRest }
choice :: { LocTerm }
: '[' sepBy2(simpleseq, '|') ']' { % L.increaseChoice >>= \x -> return $ Located ($1 <-> $3) (TChoice x (map (mergeManyWith TSeq) $2)) }
| '[' simpleseq '|' '..' simpleseq ']' { Located ($1 <-> $6) $ (TEnum Choice) (mergeManyWith TSeq $2) (mergeManyWith TSeq $5) }
| '[' simpleseq '|' simpleseq '..' simpleseq ']' { Located ($1 <-> $7) $ (TEnumThen Choice) (mergeManyWith TSeq $2) (mergeManyWith TSeq $4) (mergeManyWith TSeq $6) }
lambda :: { LocTerm }
: '\\' some(identifier) '->' term %shift { Located ($1 <-> $4) $ TLambda (map unTok $2) $4 }
polyrhythm :: { LocTerm }
: simple '%' simple %shift { Located ($1 <-> $3) $ TPoly $1 $3 }
repeat :: { LocTerm }
: simple repnum { Located ($1 <-> $2) $ TRepeat $1 (Just $ read $ Text.unpack $ unTok $2) }
| simple '!' { Located ($1 <-> $2) $ TRepeat $1 Nothing }
stack :: { LocTerm }
: '[' sepBy2(simpleseq, ',') ']' { Located ($1 <-> $3) $ TStack (map (mergeManyWith TSeq) $2) }
| '[' simpleseq ',' '..' simpleseq ']' { Located ($1 <-> $6) $ TEnum Cord (mergeManyWith TSeq $2) (mergeManyWith TSeq $5) }
| '[' simpleseq ',' simpleseq '..' simpleseq ']' { Located ($1 <-> $7) $ TEnumThen Cord (mergeManyWith TSeq $2) (mergeManyWith TSeq $4) (mergeManyWith TSeq $6) }
alt :: { LocTerm }
: simpleseq { mergeManyWith TAlt $1 }
| infix '..' infix { Located ($1 <-> $3) $ (TEnum Alt) $1 $3 }
| infix infix '..' infix { Located ($1 <-> $4) $ (TEnumThen Alt) $1 $2 $4 }
alternation :: { LocTerm }
: '<' alt '>' { mapLoc (const ($1 <-> $3)) $2 }
bracket :: { LocTerm }
: '(' term ')' { Located ($1 <-> $3) $ TBracket $2 }
simple :: { LocTerm }
: atom { $1 }
| alternation { $1 }
| sequence { $1 }
| choice { $1 }
| stack { $1 }
| lambda { $1 }
| polyrhythm { $1 }
| repeat { $1 }
| bracket { $1 }
-- special operators are left-associative
specialinfix :: { LocTerm }
: specialinfix specop simple %shift { mapLoc (const $ $1 <-> $3) $ mkAtom (\t -> TInfix $1 (Located (lLoc $2) t) $3) $2 }
| simple %shift { $1 }
-- all other operators are assumed to be right-associative, AST rotation will fix it
-- this definition is for use inside of sequences
infix :: { LocTerm }
: specialinfix operator infix %shift { mapLoc (const $ $1 <-> $3) $ mkAtom (\t -> TInfix $1 (Located (lLoc $2) t) $3) $2 }
| specialinfix %shift { $1 }
-- application is left-associative, binds stronger than operators
-- outside of sequences
app :: { LocTerm }
: app specialinfix %shift { Located ($1 <-> $2) $ TApp $1 $2 }
| specialinfix %shift { $1 }
sectionR :: { LocTerm }
: operator app %shift { mapLoc (const $ $1 <-> $2) $ mkAtom (\t -> TSectionR (Located (lLoc $1) t) $2) $1 }
sectionL :: { LocTerm }
: app operator %shift { mapLoc (const $ $1 <-> $2) $ mkAtom (\t -> TSectionL $1 (Located (lLoc $2) t)) $2 }
conditional :: { LocTerm }
: if term then term %shift { Located ($1 <-> $4) $ TIfThenElse $2 $4 Nothing }
| if term then term else term { Located ($1 <-> $6) $ TIfThenElse $2 $4 (Just $6) }
-- operators outside of sequences have the weakest binding
term :: { LocTerm }
: app operator term %shift { mapLoc (const $ $1 <-> $3) $ mkAtom (\t -> TInfix $1 (Located (lLoc $2) t) $3) $2 }
| app %shift { $1 }
| sectionR %shift { $1 }
| sectionL %shift { $1 }
| conditional { $1 }
-----------------------------------------------------------------
---------------------- parsing full syntax ----------------------
-----------------------------------------------------------------
def :: { Located Definition }
: identifier many(identifier) '=' term { Located ($1 <-> $4) $ Definition (unTok $1) (map unTok $2) $4 }
| '(' operator ')' many(identifier) '=' term { Located ($1 <-> $6) $ Definition (unTok $2) (map unTok $4) $6 }
dyndef :: { Located DynamicDefinition }
: identifier '<-' term { Located ($1 <-> $3) $ DynamicDefinition (unTok $1) $3 }
macrodef :: { Located MacroDefinition }
: macro '=' term { Located ($1 <-> $3) $ MacroDefinition (unTok $1) $3 }
command :: { Located Command }
: ':config' { Located (lLoc $1) ShowConfigPathCommand }
| ':resetconfig' { Located (lLoc $1) ResetConfigCommand }
| ':reset' { Located (lLoc $1) ResetEnvCommand }
| ':status' { Located (lLoc $1) StatusCommand }
| ':env' { Located (lLoc $1) EnvCommand }
| ':load' { Located (lLoc $1) $ LoadCommand $ unTok $1 }
| ':set' flag { Located ($1 <-> $2) $ SetCommand (unTok $2) }
| ':info' identifier { Located ($1 <-> $2) $ InfoCommand $ unTok $2 }
| ':t' term { Located ($1 <-> $2) $ TypeCommand $2 }
| ':show' term { Located ($1 <-> $2) $ ShowCommand $2 }
syntax :: { Syntax }
: dyndef { DynDef $1 }
| def { Def $1 }
| macrodef { MacroDef $1 }
| command { Command $1 }
-------------------------------------------------------------
----------------------- parsing blocks ----------------------
-------------------------------------------------------------
block :: { Block }
: some(line) { toBlock $1 }
blocksrecrev :: { [Block] }
: blocksrecrev some(bsep) block { $3:$1 }
| block { [$1] }
blocks :: { [Block] }
: some(bsep) blocksrecrev some(bsep) { reverse $2 }
| some(bsep) blocksrecrev { reverse $2 }
| blocksrecrev some(bsep) { reverse $1 }
| blocksrecrev { reverse $1 }
-------------------------------------------------------------
----------------------- parsing types -----------------------
-------------------------------------------------------------
atomType :: { Type }
: textT { TypeCon "Text" }
| numT { TypeCon "Number" }
| mapT { TypeCon "Map" }
| actionT { TypeCon "Action" }
| varT { TypeVar (unTok $1) }
fullType :: { Type }
: atomType { $1 }
| fullType '->' fullType %shift { TypeArr (noLoc $1) (noLoc $3) }
| '(' fullType ')' { $2 }
predicate :: { Predicate }
: classT varT { IsIn (unTok $1) (TypeVar (unTok $2)) }
predicates :: { [Predicate] }
: predicate '=>' { [$1] }
| { [] }
scheme :: { Scheme }
: predicates fullType %shift { generalize $1 [] (noLoc $2) }
{
parseError :: (L.Lexeme, [String]) -> L.Alex a
parseError (Located _ t, poss) = do
(L.AlexPn _ ln column, _, _, _) <- L.alexGetInput
L.alexError $ "Parse error at line " <> show ln <> ", column " <> show column
<> "\n\tunexpected " <> show t
<> "\n\texpecting " <> (intercalate "," poss)
lexer :: (L.Lexeme -> L.Alex a) -> L.Alex a
lexer = (=<< L.alexMonadScan)
unTok :: L.Lexeme -> Text
unTok (Located _ (L.IdentifierTok x)) = x
unTok (Located _ (L.NumberTok x)) = x
unTok (Located _ (L.TextTok x))= x
unTok (Located _ (L.MacroTok x))= x
unTok (Located _ (L.OperatorTok x)) = "(" <> x <> ")"
unTok (Located _ (L.SpecialOperatorTok x)) = "(" <> x <> ")"
unTok (Located _ (L.LoadCommandTok x)) = x
unTok (Located _ (L.LineTok x)) = x
unTok (Located _ (L.VarTypeTok x)) = x
unTok (Located _ (L.TypeClassTok x)) = x
unTok (Located _ (L.RepeatNumberTok x)) = x
unTok (Located _ (L.CompilerFlagTok x)) = x
unTok _ = error "can't untok"
mkAtom :: (Text -> Term) -> L.Lexeme -> LocTerm
mkAtom constr tok@(Located l _) = Located l (constr (unTok tok))
toBlock :: [L.Lexeme] -> Block
toBlock xs = Block ls
where ls = case NE.nonEmpty xs of
Just ys -> structureLines $ NE.map (\r -> Line (getLn r) (getLn r) (unTok r)) ys
Nothing -> error "Can't happen"
getLn (Located (SrcLoc (RealSrcLoc _ l _ _ _)) _) = l
parseSyntaxWithPos :: Int -> Text -> Text -> Either String Syntax
parseSyntaxWithPos ln srcp input = case parseTermWithPos ln srcp input of
Left _ -> L.runAlex input (L.setSrcPath srcp >> L.setInitialLineNum ln >> pSyntax)
Right s -> Right $ Exec s
parseSyntax :: Text -> Either String Syntax
parseSyntax input = case L.runAlex input pSyntax of
Left _ -> Exec <$> parseTerm input
Right s -> Right s
parseTermWithPos :: Int -> Text -> Text -> Either String LocTerm
parseTermWithPos ln srcp input = L.runAlex input (L.setSrcPath srcp >> L.setInitialLineNum ln >> pTerm)
parseTerm :: Text -> Either String LocTerm
parseTerm input = L.runAlex input pTerm
parseBlocks :: Int -> Text -> Either String [Block]
parseBlocks line input = L.runAlex input (L.lineLexer >> L.setInitialLineNum line >> pBlocks)
parseScheme :: Text -> Either String Scheme
parseScheme input = L.runAlex input (L.typeLexer >> pScheme)
}