hat-2.7.0.0: compiler98/Parse2.hs
module Parse2
( parseConstr, parseContexts, parseDeriving, parseFixDecls
, parseFixDecl, parseImpDecls, parseInst, parseSimple, parseType
, parseExports, parseStrict, parsePragma
, bigModId
) where
import Extra(pair,triple)
import Lex hiding (TokenId)
import Syntax hiding (TokenId)
import Lexical (PosToken)
import MkSyntax
import ParseLib
import ParseLex
import SyntaxPos
import TokenId(t_Arrow,TokenId(..))
import SysDeps (packString,unpackPS)
parseExports =
Just `parseChk` lpar `apCut` manySep comma parseExport `chk`
optional comma `chk` rpar
`orelse`
parse Nothing `chk` (lit (L_ACONID (TupleId 0))
`orelse`
lit (L_ACONID (TupleId 2)))
`orelse`
parse (Just [])
parseExport =
(uncurry ExportModid) `parseChk` lit L_module `apCut` bigModId -- 1.3
`orelse`
-- (uncurry ExportModid) `parseAp` aconid `chk` dotdot -- 1.2
-- `orelse`
(\e -> ExportEntity (getPos e) e) `parseAp` parseEntity
parseImpDecls =
manysSep semi parseImpDecl
parseImpDecl =
Importas `parseChk` lit L_import `ap` bigModId
`chk` k_as `ap` bigModId `ap` parseImpSpec -- added in H98
`orelse`
importas `parseChk` lit L_import `ap` aconid `ap` parseImpSpec
`orelse`
ImportQas `parseChk` lit L_import `chk` k_qualified `ap` bigModId
`chk` k_as `ap` bigModId `ap` parseImpSpec
`orelse`
importQas `parseChk` lit L_import `chk` k_qualified
`ap` aconid `ap` parseImpSpec -- impSpec is FAKE
where
importas m@(p,Visible _) s = Import m s
importas m@(p,Qualified a b) s = Import (deQualify m) s
-- importas m@(p,Qualified a b) s = Importas (deQualify m) (p,Visible b) s
importQas m@(p,Visible _) s = ImportQ m s
importQas m@(p,Qualified a b) s = ImportQ (deQualify m) s
-- importQas m@(p,Qualified a b) s = ImportQas (deQualify m) (p,Visible b) s
bigModId = deQualify `parseAp` aconid
deQualify m@(pos,Visible _) = m
deQualify (pos,Qualified a b) = (pos, (Visible . packString . concat)
[unpackPS b,".",unpackPS a])
parseImpSpec =
(NoHiding []) `parseChk` (k_unit `orelse` lit (L_ACONID (TupleId 2)))
-- fix for import Module() and import Module (,)
`orelse`
NoHiding `parseChk` lpar `apCut` manySep comma parseEntity `chk`
optional comma `chk` rpar
`orelse`
Hiding `parseChk` k_hiding `chk` lpar `apCut`
manySep comma parseEntity `chk` optional comma `chk` rpar
`orelse`
(Hiding []) `parseChk` k_hiding `chk` (k_unit `orelse`
lit (L_ACONID (TupleId 2)))
-- fix for hiding () and hiding (,)
`orelse`
parse (Hiding [])
parseEntity =
(uncurry EntityConClsAll) `parseAp` aconid `chk`
lpar `chk` dotdot `chk` rpar
`orelse`
(\(pos,x) -> EntityConClsSome pos x []) `parseAp` aconid `chk` tuple0
`orelse`
(uncurry EntityConClsSome) `parseAp` aconid `chk`
lpar `ap` (manySep comma (conid `orelse` varid)) `chk` rpar
`orelse`
(uncurry EntityConClsSome) `parseAp` aconid `ap` (parse [])
`orelse`
(uncurry EntityVar) `parseAp` varid
parseFixDecls =
semi `revChk` parseFixDecls
`orelse`
manysSep semi parseFixDecl
defint d =
intPrim
`orelse`
parse d
parseInfix = InfixL `parseChk` lit L_infixl
`orelse`
InfixR `parseChk` lit L_infixr
`orelse`
Infix `parseChk` lit L_infix
parseFixDecl =
triple `parseAp` parseInfix `ap` defint 9 `ap` someSep comma parseFixId
`orelse`
k_prefix `into` \ _ -> varid `into` \ (p,v) -> defint 9 `into` \ l -> parseFixId `into` \ fid ->
parse (InfixPre v,l,[fid])
parseFixId =
(uncurry FixCon) `parseAp` conop
`orelse`
(uncurry FixVar) `parseAp` varop
parseType =
parseBType `into` parseCType
`into` \ t1 -> (
(\ pos t2 -> TypeCons pos t_Arrow [t1,t2]) `parseAp` rarrow `apCut` parseType
`orelse`
parse t1)
parseCType t1 =
parseAType `into` (\ t2 -> parseCType (TypeApp t1 t2))
`orelse`
parse t1
parseBType =
( \ (pos,c) ts -> TypeCons pos c ts) `parseAp` conid `ap` some parseAType
`orelse`
parseAType
parseAType =
(uncurry TypeVar) `parseAp` varid
`orelse`
(\(pos,c) -> TypeCons pos c []) `parseAp` conid
`orelse`
mkParType `parseAp` lpar `apCut` manySep comma parseType `chk` rpar
`orelse`
mkTypeList `parseAp` lbrack `apCut` parseType `chk` rbrack
parseContexts =
lpar `revChk` manySep comma parseContext `chk` rpar `chk` impl
`orelse`
(:[]) `parseAp` parseContext `chk` impl
`orelse`
parse [] `chk` tuple0 `chk` impl
`orelse`
parse []
parseContext =
(\ (pos,c) pt_t -> Context pos c pt_t) `parseAp` conid `ap` some varid
parseSimple :: Parser (Simple TokenId) [PosToken] c
parseSimple =
(uncurry Simple) `parseAp` conid `ap` many varid
parseConstr =
(k_forall `revChk` some varid `into` \ free -> k_dot `revChk` parseConstr' free)
`orelse`
parseConstr' []
parseConstr' free =
(\a (pos,op) b -> (if null free
then Constr pos op [a,b]
else ConstrCtx free [] pos op [a,b]))
`parseAp` parseOneFieldType `ap` conop `ap` parseOneFieldType
`orelse`
(\ctxs (pos,op) a ->
case ctxs of
[] -> (if null free
then Constr pos op (concat a)
else ConstrCtx free [] pos op (concat a))
_ -> ConstrCtx free ctxs pos op (concat a)) `parseAp` parseContexts
`ap` conid `ap` many parseManyFieldType
parseOneFieldType =
(\ field typ -> (Just [field],typ)) `parseChk` lcurl `apCut` varid `chk` coloncolon `ap` parseSBType `chk` rcurl
`orelse`
(pair Nothing) `parseAp` parseSBType
parseManyFieldType =
lcurl `into` (\ _ -> manySep comma parseManyFieldType' `chk` rcurl) -- { v1,...,v2::typeN , ... w1,...,wN::typeN }
`orelse`
((:[]).pair Nothing) `parseAp` (parseStrict parseAType)
parseManyFieldType' =
(\ fields typ -> (Just fields,typ)) `parseAp` someSep comma varid `chk` coloncolon `ap` parseSBType -- v1,...,v2::typeN
parseSBType =
parseStrict parseType
`orelse`
parseType
parseStrict p =
TypeStrict `parseAp` bang `ap` p
`orelse`
p
parseDeriving :: Parser [(Pos, TokenId)] [PosToken] b
parseDeriving =
lit L_deriving `revChk` lpar `revChk` manySep comma conid `chk` rpar
`orelse`
parse [] `chk` lit L_deriving `chk` tuple0
`orelse`
(:[]) `parseChk` lit L_deriving `apCut` conid
`orelse`
parse []
{- The following code parses Haskell'98 instance heads.
-- H'98 is much more restrictive about the possible types in an instance
-- than MPTC with fundeps.
parseInst =
(\ (p,c) -> TypeCons p c []) `parseAp` conid -- type without arguments
`orelse`
lpar `revChk` parseInst' `chkCut` rpar -- type inside parenthesis
`orelse`
(\p (_,pat) -> mkInstList p pat) `parseAp` lbrack `apCut` varid
`chk` rbrack -- the list type
parseInst' =
lpar `revChk` parseInst' `chkCut` rpar -- useless extra parenthesis
`orelse`
varid `revAp` ((\pos (pa,a) (pb,b) ->
TypeCons pos t_Arrow [TypeVar pb b,TypeVar pa a])
`parseAp` rarrow `apCut` varid
`orelse`
(\a b@(p,_) -> mkParInst p (b:a)) `parseChk` comma
`apCut` someSep comma varid
)
`orelse`
mkAppInst `parseAp` conid `ap` many varid
`orelse`
(\pos-> TypeCons pos t_Arrow []) `parseAp` k_rarrow
`orelse`
-- (TypeCons noPos (t_Tuple 0) []) `parseChk` lpar `chk` rpar
-- `orelse`
parse (TypeCons noPos (t_Tuple 0) [])
-}
parseInst = parseAType
parsePragma =
DeclIgnore "PRAGMA" `parseChk` lannot `chk`
many notRannot `chk` rannot
{- possible extension for when we want to use pragmas in nhc98 -}
--parsePragma =
-- DeclPragma `parseChk` lannot `ap` conid `chk`
-- ("" `parseChk` many notRannot) `chk` rannot