amelia
/
ahc


{

{-# LANGUAGE FlexibleContexts, FlexibleInstances, ViewPatterns #-}

module Frontend.Autogen.Parser where


import qualified Data.Text as T

import Data.Text (Text)


import Frontend.Lexer.Tokens

import Frontend.Parser.Posn

import Frontend.Syntax

import Frontend.Autogen.Lexer


import Prelude hiding (span)


import Debug.Trace


}


%name parseExp Exp

%name parseMod Module

%name parseType Type


%tokentype { Token }


%monad { Alex }

%lexer { lexer } { Token TokEof _ _ }


%errorhandlertype explist

%error { parseError }


%token

 VAR { Token (TokVar _) _ _ }

 CON { Token (TokCon _) _ _ }

 STRING { Token (TokString _) _ _ }

 'eof' { Token TokEof _ _ }


 '(' { Token TokOParen _ _ }

 ')' { Token TokCParen _ _ }


 '{' { Token TokOBrace _ _ }

 '}' { Token TokCBrace _ _ }


 START { Token TokLStart _ _ }

 END { Token TokLEnd _ _ }


 '[' { Token TokOSquare _ _ }

 ']' { Token TokCSquare _ _ }


 '{-#' { Token TokOPragma _ _ }

 '#-}' { Token TokCPragma _ _ }


 '\\' { Token TokLambda _ _ }


 '->' { Token TokArrow _ _ }

 '_' { Token TokUnder _ _ }

 '::' { Token TokDoubleColon _ _ }

 ';' { Token TokSemi _ _ }

 '=' { Token TokEqual _ _ }

 ',' { Token TokComma _ _ }


 'let' { Token TokLet _ _ }

 'in' { Token TokIn _ _ }

 'data' { Token TokData _ _ }

 'case' { Token TokCase _ _ }

 'module' { Token TokModule _ _ }

 'where' { Token TokWhere _ _ }


 'import' { Token TokImport _ _ }

 'as' { Token TokAs _ _ }

 'qualified' { Token TokQualified _ _ }


%%


Exp :: { Exp }

 : InfixExp '::' Type { span $1 $3 $ Annot $1 $3 }

 | InfixExp { $1 }


InfixExp :: { Exp }

 : LeftExp {- ... -} { $1 }

-- | LeftExp qop InfixExp { Infix $1 (getVar $2) $3 }


LeftExp :: { Exp }

 : '\\' Apat List(Apat) '->' Exp { span $1 $5 (makeLams ($2:$3) $5) }

 | 'let' LaidOutList(Decl) 'in' Exp { span $1 $4 $ Let (thd $2) $4 }

 | FuncExp { $1 }


FuncExp :: { Exp }

 : FuncExp Aexp { span $1 $2 $ App $1 $2 }

 | Aexp { $1 }


Aexp :: { Exp }

 : qvar { span $1 $1 $ Ref (getVar $1) }

 | qcon { span $1 $1 $ Con (getVar $1) }

 | '(' CommaList(Exp) ')' { span $1 $3 $ makeTuple $2 }

 | STRING { span $1 $1 $ Literal (LitString (getString $1)) }


Type :: { Type }

 : Btype '->' Type { span $1 $3 $ Tyarr $1 $3 }

 | Btype { $1 }


Btype :: { Type }

 : Btype Atype { span $1 $2 $ Tyapp $1 $2 }

 | Atype { $1 }


Atype :: { Type }

 : qvar { span $1 $1 $ Tyvar (getVar $1) }

 | qcon { span $1 $1 $ Tycon (getVar $1) }

 | '(' CommaList(Type) ')' { span $1 $3 $ makeTupleType $2 }


Pat :: { Pat }

 : Lpat { $1 }


Lpat :: { Pat }

 : Apat { $1 }


Apat :: { Pat }

 : VAR { span $1 $1 $ Var (getVar $1) }

 | '_' { span $1 $1 $ Wildcard }

 | '(' CommaList(Pat) ')' { span $1 $3 $ makeTuplePattern $2 }


Decl :: { Decl }

 : VAR '::' Type { TySig (getVar $1) $3 }

 | VAR Apat List(Apat) Rhs { FunDecl (getVar $1) ($2:$3) $4 }

 | Pat Rhs { PatDecl $1 $2 }


Rhs :: { Rhs }

 : '=' Exp { BareRhs $2 [] }

 | '=' Exp 'where' LaidOutList(Decl) { BareRhs $2 (thd $4) }


LaidOutList(p)

 : START Opt(Semis) LOLContents(p, END) { (startPosn $1, lolEnd $3, lolList $3) }

 | '{' Opt(Semis) LOLContents(p, '}') { (startPosn $1, lolEnd $3, lolList $3) }


LOLContents(p, End)

 : p Semis LOLContents(p,End) { lolCons $1 $3 }

 | p Opt(Semis) End { lolCons $1 (emptyLol $3) }

 | Opt(Semis) End { emptyLol $2 }


Module :: { Module }

 : 'module' CON ImportExportList 'where' LaidOutList(ModItem)

 { Module { moduleName = getVar $2

 , moduleExports = $3

 , moduleItems = thd $5 }

 }


ImportExportList :: { Maybe [NamespacedItem Text] }

 : {-empty-} { Nothing }

 | '(' CommaList(NSItem) ')' { Just $2 }


NSItem :: { NamespacedItem Text }

 : VAR { IEVar (getVar $1) }

 | CON { IECon (getVar $1) }

 | 'module' CON { IEModule (getVar $2) }


ModItem :: { Item }

 : Decl { ModDecl $1 }

 | Import { ModImport $1 }


Import

 : 'import' qcon ImportExportList

 { Import (getVar $2) $3 False Nothing }


 | 'import' qcon ImportExportList 'as' CON

 { Import (getVar $2) $3 False (Just (getVar $5)) }


 | 'import' 'qualified' qcon ImportExportList

 { Import (getVar $3) $4 True Nothing }


 | 'import' 'qualified' qcon ImportExportList 'as' CON

 { Import (getVar $3) $4 True (Just (getVar $6)) }


Opt(p)

 : { () }

 | p { () }


Semis

 : ';' Semis { () }

 | ';' { () }


-- TODO: qualified names

qvar : VAR { $1 }

qcon : CON { $1 }


List(p)

 : {-empty-} { [] }

 | p List(p) { $1:$2 }


CommaList(p)

 : {-empty-} { [] }

 | p { [$1] }

 | p ',' CommaList(p) { $1:$3 }


Block(p)

 : START p END { (startPosn $1, endPosn $3, $2) }

 | '{' p '}' { (startPosn $1, endPosn $3, $2) }


{


type Exp = FeExpr Text

type Pat = FePat Text

type Decl = FeDecl Text

type Type = FeType Text

type Rhs = FeRhs Text

type Module = FeModule Text

type Item = ModuleItem Text


lexer cont = alexMonadScan >>= cont


parseError x = alexError (show x)


makeLams xs b = foldr Lam b xs


getVar (Token (TokVar s) _ _) = s

getVar (Token (TokCon s) _ _) = s

getVar _ = error "getVar non-var"


getString (Token (TokString s) _ _) = s

getString _ = error "getString non-string"


data LOL a = LOL { lolEnd :: Posn, lolList :: [a] }


emptyLol :: HasPosn x => x -> LOL a

emptyLol t = LOL (endPosn t) []


lolCons :: a -> LOL a -> LOL a

lolCons x (LOL p xs) = LOL p (x:xs)


makeTupleType [x] = ParenType x

makeTupleType xs = Tytup xs


makeTuplePattern [x] = ParenPat x

makeTuplePattern xs = TupPat xs


makeTuple [x] = ParenExp x

makeTuple xs = Tuple xs

}