semanticsparser.gmr

%precode {
import Data.Maybe
import Data.Either
import Data.List
import Semantics
import Control.Arrow
import Data.HashMap.Strict hiding (empty, union)

handleStatements :: [Either SemanticsRule String] -> ([SemanticsRule], [String])
handleStatements stmts = aux stmts ""
  where
    aux [] _ = ([], [])
    aux ((Left rule):stmts) t = first (rule{ _semanticsRuleAstType=t }:) $ aux stmts t
    aux ((Right t):stmts) _ = second (union [t]) $ aux stmts t
}

%operators "->" "<-" "@" "," "*->" "^->" "~"
%keywords "evaluating" "where" "restricting" "to" "case"
%linecomments "#"
%blockcomments "#[" "]#"
%separateidentitycase
%parsermap { (languageDefsParser:) }

%token
      codeBlock       { TokenCustom "CodeBlock" $$ }
      identifierPrime { TokenCustom "IdentifierPrime" $$ }
      varExtra        { TokenCustom "Directive" "varextra" }
      stateExtra      { TokenCustom "Directive" "stateextra" }
      baseType        { TokenCustom "Directive" "basetype" }
      paramType       { TokenCustom "Directive" "paramtype" }
      astType         { TokenCustom "Directive" "asttype" }
      extension       { TokenCustom "Directive" "extension" }
      importsCode     { TokenCustom "Directive" "importscode" }
      preCode         { TokenCustom "Directive" "precode" }
      outputPreCode   { TokenCustom "Directive" "outputprecode" }
      standardEnv     { TokenCustom "Directive" "standardenv" }
      hasIncludes     { TokenCustom "Directive" "hasincludes" }

Main :: Extension Imports? PreCode? OutPreCode? SemanticsDef     { (v1, v2, v3, v4, v5) }

SemanticsDef :: HasIncludes BaseType+ ParamType*
                StateExtra VarExtra
                StandardEnv Stmts                                { uncurry (SemanticsDef (fromList v2) (fromList v3) v4 v5 v6 v1) $ handleStatements v7 }

Extension :: extension identifier                                { v2 }

Imports :: importsCode codeBlock                                 { v2 }

PreCode :: preCode codeBlock                                     { v2 }

OutPreCode :: outputPreCode LowerCodeBlock                       { v2 }

LowerCodeBlock :: codeBlock { v1 } | identifierPrime { v1 } | identifier { v1 }

CodeBlock :: LowerCodeBlock { v1 } | upperIdentifier { v1 }

LowerPrime :: identifier { v1 } | identifierPrime { v1 }

BaseType :: baseType identifier stringLit                        { (v2, v3) }

ParamType :: paramType identifier LowerCodeBlock                 { (v2, v3) }

StateExtra :: stateExtra CodeBlock                               { v2 }
            | %empty                                             { "()" }

VarExtra :: varExtra CodeBlock                                   { v2 }
          | %empty                                               { "()" }

StandardEnv :: standardEnv CodeBlock                             { v2 }
             | %empty                                            { "return ()" }

HasIncludes :: hasIncludes { True } | %empty { False }

Stmts :: AstType Stmt+                                           { (Right v1):v2 }

Stmt :: Rule                                                     { Left v1 }
      | AstType                                                  { Right v1 }

AstType :: astType upperIdentifier                               { v2 }

Rule :: case codeBlock "->" codeBlock InputEnv Type Evals Where? { uncurry (SemanticsRule v2 v4 v5 v6 "" v8) v7 }

Type :: "@" stringLit                                            { SemanticsStaticBaseType v2 }
      | "@" codeBlock                                            { SemanticsStaticType v2 }
      | "@" LowerPrime                                           { SemanticsVarType v2 }
      | %empty                                                   { SemanticsCommandType }

Evals :: evaluating Eval+ Restricts                              { (v2, v3) }
       | %empty                                                  { ([], []) }

InputEnv :: "~" LowerCodeBlock                                   { v2 }
          | %empty                                               { "env" }

OutputEnv :: "~" LowerPrime                                      { v2 }
           | %empty                                              { "_" }

EvalArrow :: "->" { SemanticsDepSingle } | "*->" { SemanticsDepFold False } | "^->" { SemanticsDepFold True }

Eval :: LowerCodeBlock InputEnv EvalArrow
        LowerPrime OutputEnv Type                                { SemanticsRuleDependency v1 v2 v4 v5 (RawSemanticsDepType v6) v3 }

Restricts :: restricting Restrict+                               { v2 }
           | %empty                                              { [] }

Restrict :: LowerPrime to identifier+(',')                       { SemanticsTypeRestriction v1 v3 }

Where :: where codeBlock                                         { v2 }