gdritter repos earthling / master src / Earthling / Parser.y
master

Tree @master (Download .tar.gz)

Parser.y @master — raw · history · blame 

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
{
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}

module Earthling.Parser where

import Earthling.Types
import Earthling.Lexer

import           AlexTools
import           Data.Sequence (Seq)
import qualified Data.Sequence as S
import           Data.Text (Text)
}

%tokentype { Lexeme Tok }

%token
  IDENT    { (matchIdent -> Just $$) }
  CONSTR   { (matchConstr -> Just $$) }
  INT      { (matchInt -> Just $$) }
  DOUBLE   { (matchDouble -> Just $$) }
  STACKVAR { (matchStackVar -> Just $$) }

  "@def" { Lexeme { lexemeToken = TokKeyword "@def" } }
  "("    { Lexeme { lexemeToken = TokStructure SLParen } }
  ")"    { Lexeme { lexemeToken = TokStructure SRParen } }
  "["    { Lexeme { lexemeToken = TokStructure SLBrac } }
  "]"    { Lexeme { lexemeToken = TokStructure SRBrac } }
  "{"    { Lexeme { lexemeToken = TokStructure SLCurl } }
  "}"    { Lexeme { lexemeToken = TokStructure SRCurl } }
  "."    { Lexeme { lexemeToken = TokStructure SDot } }
  "->"   { Lexeme { lexemeToken = TokStructure SArrow } }


%monad { Parse }
%error { parseError }

%name decls decls

%%

decls :: { Seq (Decl Raw) }
  : list(decl) { $1 }

decl :: { Decl Raw }
  : "@def" IDENT wordType instrSeq { Decl (fst $2) $3 $4 }

instrSeq :: { Seq (Item Raw) }
instrSeq
  : "." { S.empty }
  | atom instrSeq { $1 S.<| $2 }

wordType :: { WordType }
wordType
  : "(" stackType "->" stackType ")"
    { WordType $2 $4 }

stackType :: { StackType }
stackType : stackBase list(itemType) { StackType $1 $2 }

stackBase :: { StackBase }
stackBase
  : "[" "]"  { EmptyStack }
  | STACKVAR { StackVar (fst $1) }

itemType :: { ItemType }
itemType
  : IDENT     { VarType (fst $1) }
  | CONSTR    { ConstrType (fst $1) }
  | wordType  { AtomType $1 }

atom :: { Item Raw }
atom
  : IDENT  { Item (AtomIdent (fst $1)) () }
  | CONSTR { Item (AtomConstr (fst $1)) () }
  | INT    { Item (AtomLiteral (IntLiteral (fst $1))) () }
  | DOUBLE { Item (AtomLiteral (DoubleLiteral (fst $1))) () }

-- utils

list(p) :: { Seq p }
  : {- empty -}   { S.empty }
  | list1(p)      { $1 }

list1(p) :: { Seq p }
  : p           { S.singleton $1 }
  | list1(p) p  { $1 S.|> $2 }

{

parseDecls :: Text -> Parse (Seq (Decl Raw))
parseDecls str = decls (lexer str)

type Parse = Either ParseError

data ParseError
  = ParseError (Maybe SourcePos) String
    deriving (Show)

parseError :: [Lexeme Tok] -> Parse a
parseError [] =  Left (ParseError Nothing "")
parseError (t:_) =
  Left (ParseError (Just (sourceFrom (lexemeRange t))) (show (lexemeToken t)))

matchIdent :: Lexeme Tok -> Maybe (Text, SourceRange)
matchIdent Lexeme
  { lexemeToken = TokIdent t
  , lexemeRange = r
  } = Just (t, r)
matchIdent _ = Nothing

matchConstr :: Lexeme Tok -> Maybe (Text, SourceRange)
matchConstr Lexeme
  { lexemeToken = TokConstr c
  , lexemeRange = r
  } = Just (c, r)
matchConstr _ = Nothing

matchInt :: Lexeme Tok -> Maybe (Integer, SourceRange)
matchInt Lexeme
  { lexemeToken = TokInt i
  , lexemeRange = r
  } = Just (i, r)
matchInt _ = Nothing

matchDouble :: Lexeme Tok -> Maybe (Double, SourceRange)
matchDouble Lexeme
  { lexemeToken = TokDouble d
  , lexemeRange = r
  } = Just (d, r)
matchDouble _ = Nothing

matchStackVar :: Lexeme Tok -> Maybe (Text, SourceRange)
matchStackVar Lexeme
  { lexemeToken = TokStackVar d
  , lexemeRange = r
  } = Just (d, r)
matchStackVar _ = Nothing

}