Parser.hs

module UHC.Light.Compiler.CoreRun.Parser
( parseModFromString
, pMod )
where
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Opts.Base
import UHC.Light.Compiler.Base.HsName.Builtin
import UHC.Util.ScanUtils
import UHC.Light.Compiler.Scanner.Common
import UHC.Light.Compiler.Scanner.Scanner
import UU.Parsing as P
import UHC.Util.ParseUtils
import UHC.Light.Compiler.Base.Parser
import Data.Maybe
import UHC.Light.Compiler.CoreRun

{-# LINE 32 "src/ehc/CoreRun/Parser.chs" #-}
-- | Parses a module. TBD: integration with other parser utils from EHC driver...
parseModFromString :: String -> Either [String] Mod
parseModFromString str = case parseToResMsgs (pMod emptyEHCOpts) $ scan corerunScanOpts (initPos $ take 80 str) str of
    (res, []) -> Right res
    (_, errs) -> Left $ map show errs

{-# LINE 44 "src/ehc/CoreRun/Parser.chs" #-}
pDifficultNm :: CRParser HsName
pDifficultNm = (\s -> {- parseHsName [s] -} mkHNm s) <$> pStr

{-# LINE 53 "src/ehc/CoreRun/Parser.chs" #-}
type CRParser hp = PlainParser Token hp

{-# LINE 62 "src/ehc/CoreRun/Parser.chs" #-}
-- | Parse module 'Mod'
pMod :: EHCOpts -> CRParser Mod
pMod _
  = (\nm nr sz main is ms bs -> mkModWithImportsMetas nm nr sz is ms (crarrayFromList bs) main)
    <$  pMODULE <*> pMaybe (mkHNm "Main") id pDollNm <*> pInt <* pCOMMA <*> pInt <*> pMb (pRARROW *> pExp) <* pSEMI
    <*> pList (pImport <* pSEMI)
    <*> pList (pMeta <* pSEMI)
    <*> pList (pExp <* pSEMI)

-- | Parse 'Import'
pImport :: CRParser Import
pImport
  = Import_Import <$ pIMPORT <*> pDollNm

-- | Parse 'Meta'
pMeta :: CRParser Meta
pMeta
  = Meta_Data <$ pDATA <*> pDifficultNm <* pEQUAL <*> pListSep pCOMMA pDataCon

-- | Parse 'DataCon'
pDataCon :: CRParser DataCon
pDataCon = DataCon_Con <$> pDifficultNm <* pRARROW <*> pInt

-- | Parse simple expression 'SExp'
pSExp :: CRParser SExp
pSExp
  =    mkInt' <$> pInt
  <|> (mkChar' . head) <$> pChar
  <|> mkString' <$> pString
  <|> mkVar' <$> pRRef

-- | Parse expression 'Exp'
pExp :: CRParser Exp
pExp = pE
  where pB =   mkExp <$> pSExp
           <|> pParens pE
           <|> mkEval <$ pKeyTk "eval" <*> pB
           <|> mkTail <$ pKeyTk "tail" <*> pB
        pE =   pB
           <|> (   mkApp <$ pKeyTk "app"   <*> pB
               <|> mkTup <$ pKeyTk "alloc" <*> pInt
               <|> mkFFI <$ pKeyTk "ffi"   <*> pString
               ) <*> pParens (pListSep pCOMMA pSExp)
           <|> dbg <$ pKeyTk "dbg" <*> pString
           <|> mkCase <$ pCASE <*> pSExp <* pOF <*> pList1 (pRARROW *> pE <* pSEMI)
           <|> mkLet  <$ pLET  <*> pInt  <* pRARROW <*> pList1 (pE <* pSEMI) <* pIN <*> pE
           <|> mkLam  <$ pLAM  <*> pInt  <* pCOMMA <*> pInt <* pRARROW <*> pE

-- | Parse reference RRef to something
pRRef :: CRParser RRef
pRRef
  = (\b sufs -> foldl (flip ($)) b sufs) <$> pB <*> pList_ng pS
  where pB =   ( (   mkLocDifRef <$ pKeyTk "d"
                 <|> mkGlobRef   <$ pKeyTk "g"
                 <|> mkImpRef    <$ pKeyTk "i"
                 <|> mkLocLevRef <$ pKeyTk "l"
                 ) <* pDOT <*> pInt <* pDOT <*> pInt
               )
           <|> ( mkModRef <$ pKeyTk "m" <* pDOT <*> pInt
               )
        pS = pDOT
              *> (   RRef_Tag <$ pKeyTk "tag"
                 <|> flip RRef_Fld <$> pInt
                 )