amelia
/
ahc


{

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

module Frontend.Autogen.Parser where


import qualified Data.Text as T

import Data.Maybe


import Frontend.Parser.Foreign

import Frontend.Lexer.Wrapper

import Frontend.Autogen.Lexer

import Frontend.Lexer.Tokens

import Frontend.Parser.Posn

import Frontend.Syntax


import qualified Prelude

import Prelude hiding (span)


import Debug.Trace


import Control.Monad


import Errors

}


%name exp Exp

%name parseMod Module

%name parseType Type


%tokentype { Token }


%monad { Alex }

%lexer { lexer } { Token TokEof _ _ }


%errorhandlertype explist

%error { parseError }


%token

 VAR { Token (TokUnqual VarId _) _ _ }

 CON { Token (TokUnqual ConId _) _ _ }


 QVAR { Token (TokQual VarId _ _) _ _ }

 QCON { Token (TokQual ConId _ _) _ _ }


 VARSYM { Token (TokUnqualOp VarId _) _ _ }

 CONSYM { Token (TokUnqualOp ConId _) _ _ }


 QVARSYM { Token (TokQualOp VarId _ _) _ _ }

 QCONSYM { Token (TokQualOp ConId _ _) _ _ }


 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 _ _ }

 '`' { Token TokTick _ _ }


 'let' { Token TokLet _ _ }

 'in' { Token TokIn _ _ }

 'data' { Token TokData _ _ }

 'case' { Token TokCase _ _ }

 'of' { Token TokOf _ _ }

 'module' { Token TokModule _ _ }

 'where' { Token TokWhere _ _ }


 'import' { Token TokImport _ _ }

 'as' { Token TokAs _ _ }

 'qualified' { Token TokQualified _ _ }


 'foreign' { Token TokForeign _ _ }

 'export' { Token TokExport _ _ }

 'safe' { Token TokSafe _ _ }

 'unsafe' { Token TokUnsafe _ _ }

 'ccall' { Token TokCCall _ _ }


%%


Exp :: { Exp }

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

 | InfixExp { $1 }


InfixExp :: { Exp }

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

 | LeftExp qop InfixExp { span $1 $3 $ Infix $1 $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 $1 }

 | gcon { span $1 $1 $ Con $1 }

 | '(' CommaList1(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 $1 }

 | gtycon { span $1 $1 $ Tycon $1 }

 | '[' Type ']' { span $1 $3 $ Tylist $2 }

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


Pat :: { Pat }

 : Lpat { $1 }


Lpat :: { Pat }

 : Apat { $1 }

 | gcon Apat List(Apat) { span $1 (endOfListPos $2 $3) (ConPat $1 ($2 : $3)) }

 | Lpat qconop Pat { span $1 $3 $ InfixPat $1 $2 $3 }


Apat :: { Pat }

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

 | gcon { span $1 $1 $ ConPat $1 [] }

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

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


Decl :: { Decl }

 : CommaList1(VAR) '::' Type { TySig (getVar `fmap` $1) $3 (startPosn (head $1)) (endPosn $3) }

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

 | Pat Rhs { PatDecl $1 $2 (startPosn $1) (endPosn $2) }


Rhs :: { Rhs }

 : '=' Exp { BareRhs $2 [] (startPosn $1) (endPosn $2) }

 | '=' Exp 'where' LaidOutList(Decl) { BareRhs $2 (thd $4) (startPosn $1) (endPosn $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)

 {% do { (imports,items) <- spanModuleItems (thd $5)

 ; pure $ Module { moduleName = toModId (getVar $2)

 , moduleExports = fst $3

 , moduleImports = imports

 , moduleItems = items }

 }

 }


ImportExportList :: { (Maybe [NamespacedItem ParsedVar], Maybe Posn) }

 : {-empty-} { (Nothing, Nothing) }

 | '(' CommaList(NSItem) ')' { (Just $2, Just (endPosn $3)) }


NSItem :: { NamespacedItem ParsedVar }

 : VAR { IEVar (getVar $1) }

 | CON { IECon (getVar $1) }

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


ModItem :: { Item }

 : Decl { ModDecl $1 (startPosn $1) (endPosn $1) }

 | Import { ModImport $1 (startPosn $1) (endPosn $1) }

 | 'foreign' FfiItem { ModFfi $2 (startPosn $1) (endPosn $2) }


Import :: { ModuleImport ParsedVar }

 : 'import' modid ImportExportList

 { Import $2 (fst $3) False Nothing (startPosn $1) (fromMaybe (endPosn $2) (snd $3)) }


 | 'import' modid ImportExportList 'as' CON

 { Import $2 (fst $3) False (Just (getVar $5)) (startPosn $1) (endPosn $5) }


 | 'import' 'qualified' modid ImportExportList

 { Import $3 (fst $4) True Nothing (startPosn $1) (fromMaybe (endPosn $3) (snd $4)) }


 | 'import' 'qualified' modid ImportExportList 'as' CON

 { Import $3 (fst $4) True (Just (getVar $6)) (startPosn $1) (endPosn $6) }


FfiItem :: { FfiItem ParsedVar }

 : 'import' CallConv Safety Entity VAR '::' Type

 -- 1 2 3 4 5 6 7

 {% do { ffiDesc <- traverse parseForeignItem $4

 ; pure $ FfiImport

 { fiVarName = getVar $5

 , fiType = $7

 , fiCallConv = $2

 , fiSafety = $3

 , fiItem = ffiDesc

 , fiBegin = startPosn $1

 , fiEnd = endPosn $7 }

 } }

 | 'import' CallConv VAR error

 {% do { state <- getUserState

 ; (here, _, _, _) <- alexGetInput

 ; let vartk = $3

 ; case lastToken state of

 Just tok -> alexThrow $ \fn ->

 emptyError { errorMessage = "malformed foreign import (did you spell safe/unsafe incorrectly?)"

 , errorInlineDesc = Just "this token was interpreted as a variable name"

 , errorBegin = startPosn vartk

 , errorEnd = startPosn vartk

 , errorFilename = fn

 , errorPointers = pointTo tok tok "so this token should have been part of a type signature"

 }

 Nothing -> alexError "no last token?"

 }

 }

 | 'export' CallConv Entity VAR '::' Type

 -- 1 2 3 4 5 6

 {% do { ffiDesc <-

 case $3 of

 Nothing -> pure Nothing

 Just x ->

 let Posn l c = startPosn x

 in parseCid (Posn l (c + 1)) 0 (getString x)

 ; pure $ FfiExport

 { fiVarName = getVar $4

 , fiType = $6

 , fiCallConv = $2

 , fiExpCid = ffiDesc

 , fiBegin = startPosn $1

 , fiEnd = endPosn $6 }

 } }


Safety :: { Maybe FfiSafety }

 : {-empty-} { Nothing }

 | 'safe' { Just Safe }

 | 'unsafe' { Just Unsafe }


CallConv :: { FfiCallConv }

 : 'ccall' { CC_CCall }

 | error

 {% do { state <- getUserState

 ; (here, _, _, _) <- alexGetInput

 ; case lastToken state of

 Just tok -> alexThrow $ \fn ->

 emptyError { errorMessage = "ahc only supports the 'ccall' calling convention"

 , errorInlineDesc = Just ("unexpected " ++ show (tokenClass tok))

 , errorBegin = startPosn tok

 , errorEnd = here

 , errorFilename = fn

 }

 Nothing -> alexError "no last token?"

 }

 }


Entity :: { Maybe Token }

 : {-empty-} { Nothing }

 | STRING { Just $1 }


Opt(p)

 : { () }

 | p { () }


Semis

 : ';' Semis { () }

 | ';' { () }


qvarid :: { ParsedVar }

qvarid

 : VAR { getVar $1 }

 | QVAR { getVar $1 }


qvar :: { ParsedVar }

 : qvarid { $1 }

 | '(' qvarsym ')' { span $1 $3 $2 }


qconid :: { ParsedVar }

qconid

 : CON { getVar $1 }

 | QCON { getVar $1 }


qcon :: { ParsedVar }

qcon

 : qconid { $1 }

 | '(' qconsym ')' { span $1 $3 $2 }


qvarsym :: { ParsedVar }

qvarsym : VARSYM { getVar $1 }

 | QVARSYM { getVar $1 }


qconsym :: { ParsedVar }

qconsym : CONSYM { getVar $1 }

 | QCONSYM { getVar $1 }


qvarop :: { ParsedVar }

 : qvarsym { $1 }

 | '`' qvar '`' { span $1 $3 $2 }


qconop :: { ParsedVar }

 : qconsym { $1 }

 | '`' qcon '`' { span $1 $3 $2 }


qop :: { ParsedVar }

 : qvarop { $1 }

 | qconop { $1 }


gcon :: { ParsedVar }

 : qcon { $1 }

 | '(' Commas ')' { BuiltinId { varId = tupleConSymName $2

 , varBuiltin = BuiltinTuple $2

 , varBegin = startPosn $1

 , varEnd = endPosn $3 }

 }


 | '[' ']' { BuiltinId { varId = T.pack "[]"

 , varBuiltin = BuiltinNil

 , varBegin = startPosn $1

 , varEnd = endPosn $2 }

 }


gtycon :: { ParsedVar }

 : gcon { $1 }

 | '(' '->' ')' { BuiltinId { varId = T.pack "[]"

 , varBuiltin = BuiltinArrow

 , varBegin = startPosn $1

 , varEnd = endPosn $2 }

 }


Commas :: { Int }

 : {- empty -} { 0 }

 | ',' Commas { (let x = $2 in x `seq` 1 + x) }


modid : qconid { toModId $1 }


List(p)

 : {-empty-} { [] }

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


CommaList(p)

 : {-empty-} { [] }

 | p { [$1] }

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


CommaList1(p)

 : 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 ParsedVar

type Pat = FePat ParsedVar

type Decl = FeDecl ParsedVar

type Type = FeType ParsedVar

type Rhs = FeRhs ParsedVar

type Module = FeModule ParsedVar

type Item = ModuleItem ParsedVar


lexer cont = do

 tok <- alexMonadScan

 mapUserState $ \s -> s { lastToken = Just tok }

 cont tok


parseError (token, expected) = do

 (here, _, _, _) <- alexGetInput

 alexThrow $ \fn -> emptyError { errorMessage = "expecting one of: " ++ unwords expected

 , errorInlineDesc = Just ("unexpected " ++ show (tokenClass token))

 , errorBegin = startPosn token

 , errorEnd = here

 , errorFilename = fn

 }


makeLams xs b = foldr Lam b xs


getVar :: Token -> ParsedVar

getVar tok@(Token (TokQual _ p s) _ _) = QualVar { varId = s, varPrefix = p, varBegin = startPosn tok, varEnd = endPosn tok }

getVar tok@(Token (TokUnqual _ s) _ _) = UnqualVar { varId = s, varBegin = startPosn tok, varEnd = endPosn tok }

getVar tok@(Token (TokQualOp _ p s) _ _) = QualVar { varId = s, varPrefix = p, varBegin = startPosn tok, varEnd = endPosn tok }

getVar tok@(Token (TokUnqualOp _ s) _ _) = UnqualVar { varId = s, varBegin = startPosn tok, varEnd = endPosn tok }

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] =

 case x of

 SPType ParenType{} _ _ -> x

 _ -> ParenType x

makeTupleType xs = Tytup xs


makeTuplePattern [x] =

 case x of

 SPPat ParenPat{} _ _ -> x

 _ -> ParenPat x

makeTuplePattern xs = TupPat xs


makeTuple [x] =

 case x of

 SPExpr ParenExp{} _ _ -> x

 _ -> ParenExp x

makeTuple xs = Tuple xs


spanModuleItems xs = do

 let

 isImport (ModImport _ _ _) = True

 isImport _ = False


 (imports, items) = Prelude.span isImport xs


 forM_ items $ \x -> case x of

 ModImport _ start end ->

 alexThrow $ \fname ->

 emptyError { errorMessage = "all import statements should be at the top of the file."

 , errorInlineDesc = Just "unexpected import statement"

 , errorFilename = fname

 , errorBegin = start

 , errorEnd = end

 }

 _ -> pure ()


 pure (map itemImport imports, items)


tupleConSymName :: Int -> T.Text

tupleConSymName n = T.singleton '(' <> T.replicate n (T.singleton ',') <> T.singleton ')'


endOfListPos :: HasPosn x => x -> [x] -> Posn

endOfListPos x [] = endPosn x

endOfListPos _ xs = endPosn (last xs)


}