Front end for External Core.
Initial go at implementing a Core front end
(enabled via -fcore); work in progress (renamer
is currently not willing to slurp in & resolve
imports.)
-> IO (ModDetails, (SDoc, SDoc, [FAST_STRING], [CoreBndr]))
deSugar dflags pcs hst mod_name unqual
- (TcResults {tc_env = type_env,
- tc_binds = all_binds,
- tc_insts = insts,
- tc_rules = rules,
- tc_fords = fo_decls})
+ (TcResults {tc_env = type_env,
+ tc_binds = all_binds,
+ tc_insts = insts,
+ tc_rules = rules,
+ tc_cbinds = core_binds,
+ tc_fords = fo_decls})
= do { showPass dflags "Desugar"
; us <- mkSplitUniqSupply 'd'
(dsProgram mod_name all_binds rules fo_decls)
(ds_binds, ds_rules, foreign_stuff) = ds_result
+
+ addCoreBinds ls =
+ case core_binds of
+ [] -> ls
+ cs -> (Rec cs) : ls
mod_details = ModDetails { md_types = type_env,
md_insts = insts,
md_rules = ds_rules,
- md_binds = ds_binds }
+ md_binds = addCoreBinds ds_binds }
-- Display any warnings
; doIfSet (not (isEmptyBag ds_warns))
module HsCore (
UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
UfBinding(..), UfConAlt(..),
- HsIdInfo(..), pprHsIdInfo,
-
+ HsIdInfo(..), pprHsIdInfo,
+
eq_ufExpr, eq_ufBinders, pprUfExpr, pprHsIdInfo,
toUfExpr, toUfBndr, ufBinderName
DeprecDecl(..), DeprecTxt,
hsDeclName, instDeclName,
tyClDeclName, tyClDeclNames, tyClDeclSysNames, tyClDeclTyVars,
- isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
+ isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, isCoreDecl,
+ countTyClDecls,
mkClassDeclSysNames, isSourceInstDecl, ifaceRuleDeclName,
getClassDeclSysNames, conDetailsTys,
collectRuleBndrSigTys
tcdSysNames :: ClassSysNames name,
tcdLoc :: SrcLoc
}
+ -- a Core value binding (coming from 'external Core' input.)
+ | CoreDecl { tcdName :: name,
+ tcdType :: HsType name,
+ tcdRhs :: UfExpr name,
+ tcdLoc :: SrcLoc
+ }
+
\end{code}
Simple classifiers
\begin{code}
-isIfaceSigDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
+isIfaceSigDecl, isCoreDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
isIfaceSigDecl (IfaceSig {}) = True
isIfaceSigDecl other = False
isClassDecl (ClassDecl {}) = True
isClassDecl other = False
+
+isCoreDecl (CoreDecl {}) = True
+isCoreDecl other = False
+
\end{code}
Dealing with names
tyClDeclNames (TySynonym {tcdName = name, tcdLoc = loc}) = [(name,loc)]
tyClDeclNames (IfaceSig {tcdName = name, tcdLoc = loc}) = [(name,loc)]
+tyClDeclNames (CoreDecl {tcdName = name, tcdLoc = loc}) = [(name,loc)]
tyClDeclNames (ForeignType {tcdName = name, tcdLoc = loc}) = [(name,loc)]
tyClDeclNames (ClassDecl {tcdName = cls_name, tcdSigs = sigs, tcdLoc = loc})
tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs
tyClDeclTyVars (ForeignType {}) = []
tyClDeclTyVars (IfaceSig {}) = []
+tyClDeclTyVars (CoreDecl {}) = []
--------------------------------
tcdType d1 == tcdType d2 &&
tcdIdInfo d1 == tcdIdInfo d2
+ (==) d1@(CoreDecl {}) d2@(CoreDecl {})
+ = tcdName d1 == tcdName d2 &&
+ tcdType d1 == tcdType d2 &&
+ tcdRhs d1 == tcdRhs d2
+
(==) d1@(ForeignType {}) d2@(ForeignType {})
= tcdName d1 == tcdName d2 &&
tcdFoType d1 == tcdFoType d2
countTyClDecls decls
= (count isClassDecl decls,
count isSynDecl decls,
- count isIfaceSigDecl decls,
+ count (\ x -> isIfaceSigDecl x || isCoreDecl x) decls,
count isDataTy decls,
count isNewTy decls)
where
then empty
else ppr (fromJust methods)
+ ppr (CoreDecl {tcdName = var, tcdType = ty, tcdRhs = rhs})
+ = getPprStyle $ \ sty ->
+ hsep [ ppr_var var, dcolon, ppr ty, ppr rhs ]
+
pp_decl_head :: Outputable name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc
pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars]
| HscAsm
| HscJava
| HscILX
+ | HscCore
| HscInterpreted
| HscNothing
deriving (Eq, Show)
{-# OPTIONS -#include "hschooks.h" #-}
-----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.89 2002/03/15 13:57:31 simonmar Exp $
+-- $Id: DriverFlags.hs,v 1.90 2002/03/29 21:39:37 sof Exp $
--
-- Driver flags
--
, ( "fvia-c", NoArg (setLang HscC) )
, ( "fvia-C", NoArg (setLang HscC) )
, ( "filx", NoArg (setLang HscILX) )
+ , ( "fcore", NoArg (setLang HscCore) )
-- "active negatives"
, ( "fno-implicit-prelude", NoArg (setDynFlag Opt_NoImplicitPrelude) )
-----------------------------------------------------------------------------
--- $Id: DriverPhases.hs,v 1.16 2002/03/04 17:01:30 simonmar Exp $
+-- $Id: DriverPhases.hs,v 1.17 2002/03/29 21:39:37 sof Exp $
--
-- GHC Driver
--
startPhase "hs" = Cpp
startPhase "hscpp" = HsPp
startPhase "hspp" = Hsc
+startPhase "hcr" = Hsc
startPhase "hs-boot" = HsBoot
startPhase "hc" = HCc
startPhase "c" = Cc
phaseInputExt Ilasm = "il"
#endif
-haskellish_suffix = (`elem` [ "hs", "hspp", "hscpp", "lhs", "hc", "raw_s" ])
-haskellish_src_suffix = (`elem` [ "hs", "hspp", "hscpp", "lhs" ])
+haskellish_suffix = (`elem` [ "hs", "lhs", "hspp", "hscpp", "hcr", "hc", "raw_s" ])
+haskellish_src_suffix = (`elem` [ "hs", "lhs", "hspp", "hscpp", "hcr"])
cish_suffix = (`elem` [ "c", "cpp", "C", "cc", "cxx", "s", "S" ])
hsbootish_suffix = (`elem` [ "hs-boot" ])
| split -> not_valid
| otherwise -> [ Hsc, HCc, As ]
+ HscCore | split && mangle -> [ Hsc, HCc, Mangle, SplitMangle, SplitAs ]
+ | mangle -> [ Hsc, HCc, Mangle, As ]
+ | split -> not_valid
+ | otherwise -> [ Hsc, HCc, As ]
+
HscAsm | split -> [ Hsc, SplitMangle, SplitAs ]
| otherwise -> [ Hsc, As ]
-- something has gone wrong. This test carefully avoids the
-- case where we aren't supposed to do any compilation, because the file
-- is already in linkable form (for example).
+-- hPutStrLn stderr (show ((start_phase `elem` pipeline,stop_phase /= Ln,stop_phase `notElem` pipeline), start_phase, stop_phase, pipeline,todo))
+-- hFlush stderr
when (start_phase `elem` pipeline &&
(stop_phase /= Ln && stop_phase `notElem` pipeline))
- (throwDyn (UsageError
+ (do
+ throwDyn (UsageError
("flag `" ++ stop_flag
++ "' is incompatible with source file `"
++ filename ++ "'" ++ show pipeline ++ show stop_phase)))
-----------------------------------------------------------------------------
--- $Id: DriverState.hs,v 1.73 2002/03/29 20:14:31 krasimir Exp $
+-- $Id: DriverState.hs,v 1.74 2002/03/29 21:39:37 sof Exp $
--
-- Settings for the driver
--
| DoMake -- ghc --make
| DoInteractive -- ghc --interactive
| DoLink -- [ the default ]
- deriving (Eq)
+ deriving (Eq,Show)
GLOBAL_VAR(v_GhcMode, DoLink, GhcMode)
GLOBAL_VAR(v_GhcModeFlag, "", String)
import IO
import MkExternalCore ( emitExternalCore )
+import ParserCore
+import ParserCoreUtils
+
\end{code}
= do -------------------------- Parser ----------------
showPass dflags "Parser"
_scc_ "Parser" do
-
+ if dopt_HscLang dflags == HscCore
+ then do
+ inp <- readFile src_filename
+ case parseCore inp 1 of
+ OkP m -> return (Just m)
+ FailP s -> hPutStrLn stderr s >> return Nothing
+ else do
buf <- hGetStringBuffer src_filename
let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.101 2002/03/26 22:08:44 sof Exp $
+-- $Id: Main.hs,v 1.102 2002/03/29 21:39:37 sof Exp $
--
-- GHC Driver program
--
let not_hs_file = not (haskellish_src_file src)
pp <- if not_hs_file || mode == StopBefore Hsc || mode == StopBefore HsPp
then return src_and_suff else do
+-- hPutStrLn stderr "before" >> hFlush stderr
phases <- genPipeline (StopBefore Hsc) stop_flag
False{-not persistent-} defaultHscLang
src_and_suff
+-- hPutStrLn stderr "after" >> hFlush stderr
pipeLoop phases src_and_suff False{-no linking-} False{-no -o flag-}
basename suffix
-- rest of compilation
hsc_lang <- dynFlag hscLang
+-- hPutStrLn stderr ("before-1 " ++ show (pp,mode)) >> hFlush stderr
phases <- genPipeline mode stop_flag True hsc_lang pp
+-- hPutStrLn stderr "after" >> hFlush stderr
(r,_) <- pipeLoop phases pp (mode==DoLink || mode==DoMkDLL)
True{-use -o flag-} basename suffix
return r
--- /dev/null
+module LexCore where
+
+import ParserCoreUtils
+import Ratio
+import Char
+
+isNameChar c = isAlpha c || isDigit c || (c == '_') || (c == '\'')
+isKeywordChar c = isAlpha c || (c == '_')
+
+lexer :: (Token -> P a) -> P a
+lexer cont [] = cont TKEOF []
+lexer cont ('\n':cs) = \line -> lexer cont cs (line+1)
+lexer cont ('-':'>':cs) = cont TKrarrow cs
+lexer cont (c:cs)
+ | isSpace c = lexer cont cs
+ | isLower c || (c == '_') = lexName cont TKname (c:cs)
+ | isUpper c = lexName cont TKcname (c:cs)
+ | isDigit c || (c == '-') = lexNum cont (c:cs)
+lexer cont ('%':cs) = lexKeyword cont cs
+lexer cont ('\'':cs) = lexChar cont cs
+lexer cont ('\"':cs) = lexString [] cont cs
+lexer cont ('#':cs) = cont TKhash cs
+lexer cont ('(':cs) = cont TKoparen cs
+lexer cont (')':cs) = cont TKcparen cs
+lexer cont ('{':cs) = cont TKobrace cs
+lexer cont ('}':cs) = cont TKcbrace cs
+lexer cont ('=':cs) = cont TKeq cs
+lexer cont (':':':':cs) = cont TKcoloncolon cs
+lexer cont ('*':cs) = cont TKstar cs
+lexer cont ('.':cs) = cont TKdot cs
+lexer cont ('\\':cs) = cont TKlambda cs
+lexer cont ('@':cs) = cont TKat cs
+lexer cont ('?':cs) = cont TKquestion cs
+lexer cont (';':cs) = cont TKsemicolon cs
+lexer cont (c:cs) = failP "invalid character" [c]
+
+lexChar cont ('\\':'x':h1:h0:'\'':cs)
+ | isHexEscape [h1,h0] = cont (TKchar (hexToChar h1 h0)) cs
+lexChar cont ('\\':cs) = failP "invalid char character" ('\\':(take 10 cs))
+lexChar cont ('\'':cs) = failP "invalid char character" ['\'']
+lexChar cont ('\"':cs) = failP "invalid char character" ['\"']
+lexChar cont (c:'\'':cs) = cont (TKchar c) cs
+
+lexString s cont ('\\':'x':h1:h0:cs)
+ | isHexEscape [h1,h0] = lexString (s++[hexToChar h1 h0]) cont cs
+lexString s cont ('\\':cs) = failP "invalid string character" ['\\']
+lexString s cont ('\'':cs) = failP "invalid string character" ['\'']
+lexString s cont ('\"':cs) = cont (TKstring s) cs
+lexString s cont (c:cs) = lexString (s++[c]) cont cs
+
+isHexEscape = all (\c -> isHexDigit c && (isDigit c || isLower c))
+
+hexToChar h1 h0 =
+ chr(
+ (digitToInt h1) * 16 +
+ (digitToInt h0))
+
+
+lexNum cont cs =
+ case cs of
+ ('-':cs) -> f (-1) cs
+ _ -> f 1 cs
+ where f sgn cs =
+ case span isDigit cs of
+ (digits,'.':c:rest) | isDigit c ->
+ cont (TKrational (numer % denom)) rest'
+ where (fpart,rest') = span isDigit (c:rest)
+ denom = 10^(length fpart)
+ numer = sgn * ((read digits) * denom + (read fpart))
+ (digits,rest) -> cont (TKinteger (sgn * (read digits))) rest
+
+lexName cont cstr cs = cont (cstr name) rest
+ where (name,rest) = span isNameChar cs
+
+lexKeyword cont cs =
+ case span isKeywordChar cs of
+ ("module",rest) -> cont TKmodule rest
+ ("import",rest) -> cont TKimport rest
+ ("data",rest) -> cont TKdata rest
+ ("newtype",rest) -> cont TKnewtype rest
+ ("forall",rest) -> cont TKforall rest
+ ("rec",rest) -> cont TKrec rest
+ ("let",rest) -> cont TKlet rest
+ ("in",rest) -> cont TKin rest
+ ("case",rest) -> cont TKcase rest
+ ("of",rest) -> cont TKof rest
+ ("coerce",rest) -> cont TKcoerce rest
+ ("note",rest) -> cont TKnote rest
+ ("external",rest) -> cont TKexternal rest
+ ("_",rest) -> cont TKwild rest
+ _ -> failP "invalid keyword" ('%':cs)
+
--- /dev/null
+{
+module ParserCore ( parseCore ) where
+
+import HsCore
+import RdrHsSyn
+import HsSyn
+import TyCon
+import TcType
+import RdrName
+import OccName
+import Module
+import ParserCoreUtils
+import LexCore
+import Literal
+import BasicTypes
+import Type
+import SrcLoc
+
+#include "../HsVersions.h"
+
+}
+
+%name parseCore
+%tokentype { Token }
+
+%token
+ '%module' { TKmodule }
+ '%import' { TKimport }
+ '%data' { TKdata }
+ '%newtype' { TKnewtype }
+ '%forall' { TKforall }
+ '%rec' { TKrec }
+ '%let' { TKlet }
+ '%in' { TKin }
+ '%case' { TKcase }
+ '%of' { TKof }
+ '%coerce' { TKcoerce }
+ '%note' { TKnote }
+ '%external' { TKexternal }
+ '%_' { TKwild }
+ '(' { TKoparen }
+ ')' { TKcparen }
+ '{' { TKobrace }
+ '}' { TKcbrace }
+ '#' { TKhash}
+ '=' { TKeq }
+ '::' { TKcoloncolon }
+ '*' { TKstar }
+ '->' { TKrarrow }
+ '\\' { TKlambda}
+ '@' { TKat }
+ '.' { TKdot }
+ '?' { TKquestion}
+ ';' { TKsemicolon }
+ NAME { TKname $$ }
+ CNAME { TKcname $$ }
+ INTEGER { TKinteger $$ }
+ RATIONAL { TKrational $$ }
+ STRING { TKstring $$ }
+ CHAR { TKchar $$ }
+
+%monad { P } { thenP } { returnP }
+%lexer { lexer } { TKEOF }
+
+%%
+
+module :: { RdrNameHsModule }
+ : '%module' modid imports tdefs vdefgs
+ { HsModule $2 Nothing Nothing $3 ($4 ++ concat $5) Nothing noSrcLoc}
+
+imports :: { [ImportDecl RdrName] }
+ : {- empty -} { [] }
+ | imp ';' imports { $1 : $3 }
+
+imp :: { ImportDecl RdrName }
+ : '%import' modid { ImportDecl $2 ImportByUser True{-qual-} Nothing Nothing noSrcLoc }
+
+tdefs :: { [RdrNameHsDecl] }
+ : {- empty -} {[]}
+ | tdef ';' tdefs {$1:$3}
+
+tdef :: { RdrNameHsDecl }
+ : '%data' qcname tbinds '=' '{' cons1 '}'
+ { TyClD (TyData DataType [] $2 $3 (DataCons $6) Nothing [] noSrcLoc) }
+ | '%newtype' qcname tbinds trep
+ { TyClD (TyData NewType [] $2 $3 ($4 $2 $3) Nothing [] noSrcLoc) }
+
+trep :: { (RdrName -> [HsTyVarBndr RdrName] -> DataConDetails (ConDecl RdrName)) }
+ : {- empty -} { (\ x ts -> Unknown) }
+ | '=' ty { (\ x ts -> DataCons [ConDecl x x ts [] (VanillaCon [unbangedType $2]) noSrcLoc]) }
+
+tbind :: { HsTyVarBndr RdrName }
+ : name { IfaceTyVar $1 liftedTypeKind }
+ | '(' name '::' akind ')' { IfaceTyVar $2 $4 }
+
+tbinds :: { [HsTyVarBndr RdrName] }
+ : {- empty -} { [] }
+ | tbind tbinds { $1:$2 }
+
+vdefgs :: { [[RdrNameHsDecl]] }
+ : {- empty -} { [] }
+ | vdefg ';' vdefgs { ($1:$3) }
+
+vdefg :: { [RdrNameHsDecl] }
+ : '%rec' '{' vdefs1 '}' { $3 }
+ | vdef { [$1] }
+
+vdefs1 :: { [RdrNameHsDecl] }
+ : vdef { [$1] }
+ | vdef ';' vdefs1 { $1:$3 }
+
+vdef :: { RdrNameHsDecl }
+ : qname '::' ty '=' exp { TyClD (CoreDecl $1 $3 $5 noSrcLoc) }
+
+
+vbind :: { (RdrName, RdrNameHsType) }
+ : '(' name '::' ty ')' { ($2,$4) }
+
+vbinds :: { [(RdrName, RdrNameHsType)] }
+ : {-empty -} { [] }
+ | vbind vbinds { $1:$2 }
+
+bind :: { UfBinder RdrName }
+ : '@' tbind { let (IfaceTyVar v k) = $2 in UfTyBinder v k }
+ | vbind { let (v,ty) = $1 in UfValBinder v ty }
+
+binds1 :: { [UfBinder RdrName] }
+ : bind { [$1] }
+ | bind binds1 { $1:$2 }
+
+attbinds :: { [RdrNameHsTyVar] }
+ : {- empty -} { [] }
+ | '@' tbind attbinds { $2:$3 }
+
+akind :: { Kind }
+ : '*' { liftedTypeKind }
+ | '#' { unliftedTypeKind }
+ | '?' { openTypeKind }
+ | '(' kind ')' { $2 }
+
+kind :: { Kind }
+ : akind { $1 }
+ | akind '->' kind { mkArrowKind $1 $3 }
+
+cons1 :: { [ConDecl RdrName] }
+ : con { [$1] }
+ | con ';' cons1 { $1:$3 }
+
+con :: { ConDecl RdrName }
+ : qcname attbinds atys
+ { ConDecl $1 $1 $2 [] (VanillaCon (map unbangedType $3)) noSrcLoc}
+
+atys :: { [ RdrNameHsType] }
+ : {- empty -} { [] }
+ | aty atys { $1:$2 }
+
+aty :: { RdrNameHsType }
+ : name { HsTyVar $1 }
+ | qcname { HsTyVar $1 }
+ | '(' ty ')' { $2 }
+
+
+bty :: { RdrNameHsType }
+ : aty { $1 }
+ | bty aty { HsAppTy $1 $2 }
+
+ty :: { RdrNameHsType }
+ : bty { $1 }
+ | bty '->' ty { HsFunTy $1 $3 }
+ | '%forall' tbinds '.' ty { HsForAllTy (Just $2) [] $4 }
+
+aexp :: { UfExpr RdrName }
+ : qname { UfVar $1 }
+ | qcname { UfVar $1 }
+ | lit { UfLit $1 }
+ | '(' exp ')' { $2 }
+
+fexp :: { UfExpr RdrName }
+ : fexp aexp { UfApp $1 $2 }
+ | fexp '@' aty { UfApp $1 (UfType $3) }
+ | aexp { $1 }
+
+exp :: { UfExpr RdrName }
+ : fexp { $1 }
+ | '\\' binds1 '->' exp { foldr UfLam $4 $2 }
+ | '%let' vdefg '%in' exp { UfLet (toUfBinder $2) $4 }
+ | '%case' aexp '%of' vbind
+ '{' alts1 '}' { UfCase $2 (fst $4) $6 }
+ | '%coerce' aty exp { UfNote (UfCoerce $2) $3 } -- what about the 'from' type?
+ | '%note' STRING exp
+ { case $2 of
+ --"SCC" -> UfNote (UfSCC "scc") $3
+ "InlineCall" -> UfNote UfInlineCall $3
+ "InlineMe" -> UfNote UfInlineMe $3
+ }
+-- | '%external' STRING aty { External $2 $3 }
+
+alts1 :: { [UfAlt RdrName] }
+ : alt { [$1] }
+ | alt ';' alts1 { $1:$3 }
+
+alt :: { UfAlt RdrName }
+ : qcname attbinds vbinds '->' exp
+ { {- ToDo: sort out-} (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) }
+ | lit '->' exp
+ { (UfLitAlt $1, [], $3) }
+ | '%_' '->' exp
+ { (UfDefault, [], $3) }
+
+lit :: { Literal }
+ : '(' INTEGER '::' aty ')' { MachInt $2 }
+ | '(' RATIONAL '::' aty ')' { MachDouble $2 }
+ | '(' CHAR '::' aty ')' { MachChar (fromEnum $2) }
+ | '(' STRING '::' aty ')' { MachStr (_PK_ $2) }
+
+name :: { RdrName }
+ : NAME { mkUnqual varName (_PK_ $1) }
+
+cname :: { String }
+ : CNAME { $1 }
+
+mname :: { String }
+ : CNAME { $1 }
+
+modid :: { ModuleName }
+ : CNAME { mkSysModuleNameFS (_PK_ $1) }
+
+qname :: { RdrName }
+ : name { $1 }
+ | mname '.' NAME
+ { mkIfaceOrig varName (_PK_ $1,_PK_ $3) }
+
+qcname :: { RdrName }
+ : mname '.' cname
+ { mkIfaceOrig dataName (_PK_ $1,_PK_ $3) }
+
+
+{
+
+toUfBinder :: [RdrNameHsDecl] -> UfBinding RdrName
+toUfBinder xs =
+ case xs of
+ [x] -> uncurry UfNonRec (conv x)
+ _ -> UfRec (map conv xs)
+ where
+ conv (TyClD (CoreDecl n ty rhs _)) = (UfValBinder n ty, rhs)
+
+happyError :: P a
+happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
+
+}
--- /dev/null
+module ParserCoreUtils where
+
+data ParseResult a = OkP a | FailP String
+type P a = String -> Int -> ParseResult a
+
+thenP :: P a -> (a -> P b) -> P b
+m `thenP` k = \ s l ->
+ case m s l of
+ OkP a -> k a s l
+ FailP s -> FailP s
+
+returnP :: a -> P a
+returnP m _ _ = OkP m
+
+failP :: String -> P a
+failP s s' _ = FailP (s ++ ":" ++ s')
+
+data Token =
+ TKmodule
+ | TKimport
+ | TKdata
+ | TKnewtype
+ | TKforall
+ | TKrec
+ | TKlet
+ | TKin
+ | TKcase
+ | TKof
+ | TKcoerce
+ | TKnote
+ | TKexternal
+ | TKwild
+ | TKoparen
+ | TKcparen
+ | TKobrace
+ | TKcbrace
+ | TKhash
+ | TKeq
+ | TKcoloncolon
+ | TKstar
+ | TKrarrow
+ | TKlambda
+ | TKat
+ | TKdot
+ | TKquestion
+ | TKsemicolon
+ | TKname String
+ | TKcname String
+ | TKinteger Integer
+ | TKrational Rational
+ | TKstring String
+ | TKchar Char
+ | TKEOF
+
= newTopBinder mod var src_loc `thenRn` \ var_name ->
returnRn (Avail var_name, [])
+getTyClDeclBinders mod (CoreDecl {tcdName = var, tcdLoc = src_loc})
+ = newTopBinder mod var src_loc `thenRn` \ var_name ->
+ returnRn (Avail var_name, [])
+
getTyClDeclBinders mod tycl_decl
= new_top_bndrs mod (tyClDeclNames tycl_decl) `thenRn` \ names@(main_name:_) ->
new_top_bndrs mod (tyClDeclSysNames tycl_decl) `thenRn` \ sys_names ->
Just _ -> emptyFVs -- Source code, so the default methods
-- are *bound* not *free*
+tyClDeclFVs (CoreDecl {tcdType = ty, tcdRhs = rhs})
+ = extractHsTyNames ty `plusFV` ufExprFVs rhs
+
----------------
hsSigsFVs sigs = plusFVs (map hsSigFVs sigs)
get_gates is_used (ForeignType {tcdName = tycon}) = unitNameSet tycon
get_gates is_used (IfaceSig {tcdType = ty}) = extractHsTyNames ty
+get_gates is_used (CoreDecl {tcdType = ty}) = extractHsTyNames ty
get_gates is_used (ClassDecl { tcdCtxt = ctxt, tcdName = cls, tcdTyVars = tvs, tcdSigs = sigs})
= (super_cls_and_sigs `addOneToNameSet` cls) `unionNameSets`
where
doc_str = text "In the interface signature for" <+> quotes (ppr name)
+rnTyClDecl (CoreDecl {tcdName = name, tcdType = ty, tcdRhs = rhs, tcdLoc = loc})
+ = pushSrcLocRn loc $
+ lookupTopBndrRn name `thenRn` \ name' ->
+ rnHsType doc_str ty `thenRn` \ ty' ->
+ rnCoreExpr rhs `thenRn` \ rhs' ->
+ returnRn (CoreDecl {tcdName = name', tcdType = ty', tcdRhs = rhs', tcdLoc = loc})
+ where
+ doc_str = text "In the Core declaration for" <+> quotes (ppr name)
+
rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
= pushSrcLocRn loc $
lookupTopBndrRn name `thenRn` \ name' ->
collectMonoBinders, andMonoBinds,
collectSigTysFromMonoBinds
)
-import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
+import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds,
+ RenamedTyClDecl )
import TcHsSyn ( TcMonoBinds, TcId, zonkId, mkHsLet )
import TcMonad
TcMonoBinds, TcHsBinds, TcPat,
TcExpr, TcGRHSs, TcGRHS, TcMatch,
TcStmt, TcArithSeqInfo, TcRecordBinds,
- TcHsModule, TcCoreExpr, TcDictBinds,
+ TcHsModule, TcDictBinds,
TcForeignExportDecl,
TypecheckedHsBinds, TypecheckedRuleDecl,
TypecheckedMatch, TypecheckedHsModule,
TypecheckedGRHSs, TypecheckedGRHS,
TypecheckedRecordBinds, TypecheckedDictBinds,
- TypecheckedMatchContext,
+ TypecheckedMatchContext, TypecheckedCoreBind,
mkHsTyApp, mkHsDictApp, mkHsConApp,
mkHsTyLam, mkHsDictLam, mkHsLet,
TcId,
zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr,
- zonkForeignExports, zonkRules
+ zonkForeignExports, zonkRules, zonkCoreExpr, zonkCoreBinds
) where
#include "HsVersions.h"
)
import TysWiredIn ( charTy, stringTy, intTy, integerTy,
mkListTy, mkPArrTy, mkTupleTy, unitTy )
-import CoreSyn ( Expr )
+import CoreSyn ( Expr(..), CoreExpr, CoreBind, Bind(..), CoreAlt, Note(..) )
import Var ( isId )
import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName )
import Bag
type TcRecordBinds = HsRecordBinds TcId TcPat
type TcHsModule = HsModule TcId TcPat
-type TcCoreExpr = Expr TcId
type TcForeignExportDecl = ForeignDecl TcId
type TcRuleDecl = RuleDecl TcId TcPat
type TypecheckedHsModule = HsModule Id TypecheckedPat
type TypecheckedForeignDecl = ForeignDecl Id
type TypecheckedRuleDecl = RuleDecl Id TypecheckedPat
+type TypecheckedCoreBind = (Id, CoreExpr)
\end{code}
\begin{code}
returnNF_Tc ((f, new_pat, pun), ids)
zonkPat (LitPat lit ty)
- = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
returnNF_Tc (LitPat lit new_ty, emptyBag)
zonkPat (SigPat pat ty expr)
returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
zonkPat (NPlusKPat n k ty e1 e2)
- = zonkIdBndr n `thenNF_Tc` \ new_n ->
- zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- zonkExpr e1 `thenNF_Tc` \ new_e1 ->
- zonkExpr e2 `thenNF_Tc` \ new_e2 ->
+ = zonkIdBndr n `thenNF_Tc` \ new_n ->
+ zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr e2 `thenNF_Tc` \ new_e2 ->
returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
zonkPat (DictPat ds ms)
- = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds ->
- mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms ->
+ = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds ->
+ mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms ->
returnNF_Tc (DictPat new_ds new_ms,
listToBag new_ds `unionBags` listToBag new_ms)
= zonkIdOcc fun `thenNF_Tc` \ fun' ->
returnNF_Tc (IfaceRuleOut fun' rule)
\end{code}
+
+\begin{code}
+zonkCoreBinds :: [(Id, Type, CoreExpr)] -> NF_TcM [(Id, CoreExpr)]
+zonkCoreBinds ls = mapNF_Tc zonkOne ls
+ where
+ zonkOne (i, t, e) =
+ zonkIdOcc i `thenNF_Tc` \ i' ->
+ zonkCoreExpr e `thenNF_Tc` \ e' ->
+ returnNF_Tc (i',e')
+
+-- needed?
+zonkCoreExpr :: CoreExpr -> NF_TcM CoreExpr
+zonkCoreExpr e =
+ case e of
+ Var i ->
+ zonkIdOcc i `thenNF_Tc` \ i' ->
+ returnNF_Tc (Var i')
+ Lit l -> returnNF_Tc (Lit l)
+ App f arg ->
+ zonkCoreExpr f `thenNF_Tc` \ f' ->
+ zonkCoreExpr arg `thenNF_Tc` \ arg' ->
+ returnNF_Tc (App f' arg')
+ Lam b e ->
+ zonkIdOcc b `thenNF_Tc` \ b' ->
+ zonkCoreExpr e `thenNF_Tc` \ e' ->
+ returnNF_Tc (Lam b' e')
+ Case scrut n alts ->
+ zonkCoreExpr scrut `thenNF_Tc` \ scrut' ->
+ zonkIdOcc n `thenNF_Tc` \ n' ->
+ mapNF_Tc zonkCoreAlt alts `thenNF_Tc` \ alts' ->
+ returnNF_Tc (Case scrut' n' alts')
+ Let b rhs ->
+ zonkCoreBind b `thenNF_Tc` \ b' ->
+ zonkCoreExpr rhs `thenNF_Tc` \ rhs' ->
+ returnNF_Tc (Let b' rhs')
+ Note note e ->
+ zonkNote note `thenNF_Tc` \ note' ->
+ zonkCoreExpr e `thenNF_Tc` \ e' ->
+ returnNF_Tc (Note note' e')
+ Type t ->
+ zonkTcTypeToType t `thenNF_Tc` \ t' ->
+ returnNF_Tc (Type t')
+
+zonkCoreBind :: CoreBind -> NF_TcM CoreBind
+zonkCoreBind (NonRec b e) =
+ zonkIdOcc b `thenNF_Tc` \ b' ->
+ zonkCoreExpr e `thenNF_Tc` \ e' ->
+ returnNF_Tc (NonRec b' e')
+zonkCoreBind (Rec bs) =
+ mapNF_Tc zonkIt bs `thenNF_Tc` \ bs' ->
+ returnNF_Tc (Rec bs')
+ where
+ zonkIt (b,e) =
+ zonkIdOcc b `thenNF_Tc` \ b' ->
+ zonkCoreExpr e `thenNF_Tc` \ e' ->
+ returnNF_Tc (b',e')
+
+
+zonkCoreAlt :: CoreAlt -> NF_TcM CoreAlt
+zonkCoreAlt (ac, bs, rhs) =
+ mapNF_Tc zonkIdOcc bs `thenNF_Tc` \ bs' ->
+ zonkCoreExpr rhs `thenNF_Tc` \ rhs' ->
+ returnNF_Tc (ac, bs', rhs')
+
+zonkNote :: Note -> NF_TcM Note
+zonkNote n =
+ case n of
+ Coerce t f ->
+ zonkTcTypeToType t `thenNF_Tc` \ t' ->
+ zonkTcTypeToType f `thenNF_Tc` \ f' ->
+ returnNF_Tc (Coerce t' f')
+ _ -> returnNF_Tc n
+
+\end{code}
\section[TcIfaceSig]{Type checking of type signatures in interface files}
\begin{code}
-module TcIfaceSig ( tcInterfaceSigs, tcDelay, tcVar, tcCoreExpr, tcCoreLamBndrs ) where
+module TcIfaceSig ( tcInterfaceSigs,
+ tcDelay,
+ tcVar,
+ tcCoreExpr,
+ tcCoreLamBndrs,
+ tcCoreBinds ) where
#include "HsVersions.h"
import IdInfo
import TyCon ( tyConDataCons )
import DataCon ( DataCon, dataConId, dataConSig, dataConArgTys )
-import Type ( mkTyVarTys, splitTyConApp )
+import Type ( Type, mkTyVarTys, splitTyConApp )
import TysWiredIn ( tupleCon )
import Var ( mkTyVar, tyVarKind )
import Name ( Name, nameIsLocalOrFrom )
Nothing -> pprPanic "tcCoreAlt" (ppr con_id))
\end{code}
+%************************************************************************
+%* *
+\subsection{Core decls}
+%* *
+%************************************************************************
+
+
+\begin{code}
+tcCoreBinds :: [RenamedTyClDecl]
+ -> TcM [(Id, Type, CoreExpr)]
+tcCoreBinds ls = mapTc tcOne ls
+ where
+ tcOne (CoreDecl { tcdName = nm, tcdType = ty, tcdRhs = rhs }) =
+ tcVar nm `thenTc` \ i ->
+ tcIfaceType ty `thenTc` \ ty' ->
+ tcCoreExpr rhs `thenTc` \ rhs' ->
+ returnTc (i,ty',rhs')
+
+\end{code}
+
+
+
\begin{code}
ifaceSigCtxt sig_name
= hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]
import CmdLineOpts ( DynFlag(..), DynFlags, dopt )
import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
Stmt(..), InPat(..), HsMatchContext(..), HsDoContext(..), RuleDecl(..),
- isSourceInstDecl, mkSimpleMatch, placeHolderType
+ isSourceInstDecl, mkSimpleMatch, placeHolderType, isCoreDecl
)
import PrelNames ( ioTyConName, printName,
returnIOName, bindIOName, failIOName, runMainName,
RenamedRuleDecl, RenamedTyClDecl, RenamedInstDecl )
import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr,
TypecheckedForeignDecl, TypecheckedRuleDecl,
+ TypecheckedCoreBind,
zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet,
- zonkExpr, zonkIdBndr
+ zonkExpr, zonkIdBndr, zonkCoreBinds
)
import Rename ( RnResult(..) )
)
import TcRules ( tcIfaceRules, tcSourceRules )
import TcForeign ( tcForeignImports, tcForeignExports )
-import TcIfaceSig ( tcInterfaceSigs )
+import TcIfaceSig ( tcInterfaceSigs, tcCoreBinds )
import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls1, addInstDFuns, initInstEnv, tcInstDecls2 )
import TcSimplify ( tcSimplifyTop, tcSimplifyInfer )
import TcTyClsDecls ( tcTyAndClassDecls )
tc_insts :: [DFunId], -- Instances
tc_rules :: [TypecheckedRuleDecl], -- Transformation rules
tc_binds :: TypecheckedMonoBinds, -- Bindings
+ tc_cbinds :: [TypecheckedCoreBind], -- (external)Core value decls/bindings.
tc_fords :: [TypecheckedForeignDecl] -- Foreign import & exports.
}
traceTc (text "Tc5") `thenNF_Tc_`
tcTopBinds (val_binds `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env2), lie_valdecls) ->
+ tcCoreBinds core_binds `thenTc` \ core_binds' ->
-- Second pass over class and instance declarations,
-- plus rules and foreign exports, to generate bindings
tcSetEnv env2 $
in
traceTc (text "Tc7") `thenNF_Tc_`
zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', final_env) ->
+ zonkCoreBinds core_binds' `thenNF_Tc` \ core_binds' ->
tcSetEnv final_env $
-- zonkTopBinds puts all the top-level Ids into the tcGEnv
traceTc (text "Tc8") `thenNF_Tc_`
tc_insts = map iDFunId inst_info,
tc_binds = all_binds',
tc_fords = foi_decls ++ foe_decls',
+ tc_cbinds = core_binds',
tc_rules = src_rules'
}
)
rule_decls = [d | RuleD d <- decls]
inst_decls = [d | InstD d <- decls]
val_decls = [d | ValD d <- decls]
+
+ core_binds = [d | d <- tycl_decls, isCoreDecl d]
(src_inst_decls, iface_inst_decls) = partition isSourceInstDecl inst_decls
(src_rule_decls, iface_rule_decls) = partition (isSourceRuleDecl this_mod) rule_decls
projects / ghc-hetmet.git / commitdiff