amelia
/
ahc


{

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

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.Var

import Frontend.Syntax


import qualified Prelude

import Prelude hiding (span)


import Debug.Trace


import Control.Monad


import Errors


import Ahc.Data.Lens.Tuple (Field3(_3))

import Ahc.Data.Lens ((^.))

}


%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 (($2 :: (_,_,_)) ^. _3) $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 (($4 :: (_, _, _)) ^. _3) (startPosn $1) (endPosn $4) }


LaidOutList(p)

 : START Opt(Semis) LOLContents(p, CLOSE) { (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' modid ImportExportList 'where' LaidOutList(ModItem)

 {% do { (imports,items) <- spanModuleItems (($5 :: (_,_,_)) ^. _3)

 ; pure $ Module { moduleName = toModId $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

 ; AI 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

 ; AI 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 }

 | qvarid

 {% do { AI here _ _ _ <- alexGetInput

 ; alexThrow $ \fn ->

 emptyError { errorMessage = "module names must be uppercase"

 , errorInlineDesc = Just ("this is lowercase!")

 , errorBegin = startPosn $1

 , errorEnd = endPosn $1

 , errorFilename = fn

 }

 }

 }


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 CLOSE { (startPosn $1, endPosn $2, $2) }

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


CLOSE :: { Posn }

 : END { endPosn $1 }

 | error {% do { popLayoutContext

 ; AI here _ _ _ <- alexGetInput

 ; pure here

 }

 }


{


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

 AI 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)


}