module FrontEnd.ParseUtils (
splitTyConApp
, mkRecConstrOrUpdate
, checkPrec
, checkContext
, checkDataHeader
, checkPattern
, checkPatterns
, checkExpr
, checkValDef
, checkUnQual
, readInteger
, readRational
, fixupHsDecls
, parseError
, parseExport
, qualTypeToClassHead
, doForeign
, doForeignEq
) where
import Data.Char
import Data.Maybe
import Data.Monoid
import Data.Ratio
import qualified Data.Set as Set
import qualified Data.Traversable as T
import C.FFI
import FrontEnd.HsSyn
import FrontEnd.ParseMonad
import FrontEnd.SrcLoc
import Name.Name
import Name.Names
import PackedString
parseError :: String -> P a
parseError = fail
splitTyConApp :: HsType -> P (Name,[HsType])
splitTyConApp t0 = split t0 []
where
split :: HsType -> [HsType] -> P (Name,[HsType])
split (HsTyApp t u) ts = split t (u:ts)
split (HsTyCon t) ts = return (t,ts)
split _ _ = fail "Illegal data/newtype declaration"
qualTypeToClassHead :: HsQualType -> P HsClassHead
qualTypeToClassHead qt = do
let fromHsTypeApp t = f t [] where
f (HsTyApp a b) rs = f a (b:rs)
f t rs = (t,rs)
case fromHsTypeApp $ hsQualTypeType qt of
(HsTyCon className,as) -> return HsClassHead { hsClassHeadContext = hsQualTypeContext qt, hsClassHead = className, hsClassHeadArgs = as }
_ -> fail "Invalid Class Head"
checkContext :: HsType -> P HsContext
checkContext (HsTyCon (toName TypeConstructor -> name)) | name == tc_Unit = return []
checkContext (HsTyTuple ts) =
mapM checkAssertion ts
checkContext t = do
c <- checkAssertion t
return [c]
checkAssertion :: HsType -> P HsAsst
checkAssertion t = checkAssertion' [] t
where checkAssertion' ts (HsTyCon c) = tast (c,ts)
checkAssertion' ts (HsTyApp a t) = checkAssertion' (t:ts) a
checkAssertion' _ _ = fail "Illegal class assertion"
tast (a,[HsTyVar n]) = return (HsAsst a [n])
tast _ = fail "Invalid Class. multiparameter classes not yet supported"
checkPatterns :: [HsExp] -> P [HsPat]
checkPatterns es = mapM checkPattern es
checkDataHeader :: HsQualType -> P (HsContext,Name,[Name])
checkDataHeader (HsQualType cs t) = do
(c,ts) <- checkSimple "data/newtype" t []
return (cs,c,ts)
checkSimple :: String -> HsType -> [Name] -> P ((Name,[Name]))
checkSimple kw (HsTyApp l (HsTyVar a)) xs = checkSimple kw l (a:xs)
checkSimple _kw (HsTyCon t) xs = return (t,xs)
checkSimple kw _ _ = fail ("Illegal " ++ kw ++ " declaration")
checkPattern :: HsExp -> P HsPat
checkPattern e = checkPat e []
checkPat :: HsExp -> [HsPat] -> P HsPat
checkPat (HsCon c) args = return (HsPApp c args)
checkPat (HsApp f x) args = do
x <- checkPat x []
checkPat f (x:args)
checkPat e [] = case e of
HsVar x -> return (HsPVar x)
HsLit l -> return (HsPLit l)
HsInfixApp l op r -> do
l <- checkPat l []
r <- checkPat r []
case op of
HsCon c -> return (HsPInfixApp l c r)
_ -> patFail
HsTuple es -> do
ps <- mapM (\e -> checkPat e []) es
return (HsPTuple ps)
HsUnboxedTuple es -> do
ps <- mapM (\e -> checkPat e []) es
return (HsPUnboxedTuple ps)
HsList es -> do
ps <- mapM (\e -> checkPat e []) es
return (HsPList ps)
HsParen e -> do
p <- checkPat e []
return (HsPParen p)
HsAsPat n e -> do
p <- checkPat e []
return (HsPAsPat n p)
HsWildCard _ -> return HsPWildCard
HsIrrPat e -> do
p <- T.mapM checkPattern e
return (HsPIrrPat p)
HsBangPat e -> do
p <- T.mapM checkPattern e
return (HsPBangPat p)
HsRecConstr c fs -> do
fs <- mapM checkPatField fs
return (HsPRec c fs)
HsNegApp (HsLit l) -> return (HsPNeg (HsPLit l))
HsExpTypeSig sl e t -> do
p <- checkPat e []
return (HsPTypeSig sl p t)
_ -> patFail
checkPat _ _ = patFail
checkPatField :: HsFieldUpdate -> P HsPatField
checkPatField (HsFieldUpdate n e) = do
p <- checkPat e []
return (HsPFieldPat n p)
patFail :: P a
patFail = fail "Parse error in pattern"
checkExpr :: HsExp -> P HsExp
checkExpr e = case e of
HsVar _ -> return e
HsCon _ -> return e
HsLit _ -> return e
HsInfixApp e1 op e2 -> check2Exprs e1 e2 (flip HsInfixApp op)
HsApp e1 e2 -> check2Exprs e1 e2 HsApp
HsNegApp e -> check1Expr e HsNegApp
HsLambda loc ps e -> check1Expr e (HsLambda loc ps)
HsLet bs e -> check1Expr e (HsLet bs)
HsIf e1 e2 e3 -> check3Exprs e1 e2 e3 HsIf
HsCase e alts -> do
alts <- mapM checkAlt alts
e <- checkExpr e
return (HsCase e alts)
HsDo stmts -> do
stmts <- mapM checkStmt stmts
return (HsDo stmts)
HsTuple es -> checkManyExprs es HsTuple
HsUnboxedTuple es -> checkManyExprs es HsUnboxedTuple
HsList es -> checkManyExprs es HsList
HsParen e -> check1Expr e HsParen
HsLeftSection e op -> check1Expr e (flip HsLeftSection op)
HsRightSection op e -> check1Expr e (HsRightSection op)
HsRecConstr c fields -> do
fields <- mapM checkField fields
return (HsRecConstr c fields)
HsRecUpdate e fields -> do
fields <- mapM checkField fields
e <- checkExpr e
return (HsRecUpdate e fields)
HsEnumFrom e -> check1Expr e HsEnumFrom
HsEnumFromTo e1 e2 -> check2Exprs e1 e2 HsEnumFromTo
HsEnumFromThen e1 e2 -> check2Exprs e1 e2 HsEnumFromThen
HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo
HsListComp e stmts -> do
stmts <- mapM checkStmt stmts
e <- checkExpr e
return (HsListComp e stmts)
HsExpTypeSig loc e ty -> do
e <- checkExpr e
return (HsExpTypeSig loc e ty)
HsAsPat _ _ -> fail "@ only valid in pattern"
HsWildCard sl -> return $ HsWildCard sl
HsIrrPat _ -> fail "~ only valid in pattern"
_ -> fail "Parse error in expression"
check1Expr :: HsExp -> (HsExp -> a) -> P a
check1Expr e1 f = do
e1 <- checkExpr e1
return (f e1)
check2Exprs :: HsExp -> HsExp -> (HsExp -> HsExp -> a) -> P a
check2Exprs e1 e2 f = do
e1 <- checkExpr e1
e2 <- checkExpr e2
return (f e1 e2)
check3Exprs :: HsExp -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> a) -> P a
check3Exprs e1 e2 e3 f = do
e1 <- checkExpr e1
e2 <- checkExpr e2
e3 <- checkExpr e3
return (f e1 e2 e3)
checkManyExprs :: [HsExp] -> ([HsExp] -> a) -> P a
checkManyExprs es f = do
es <- mapM checkExpr es
return (f es)
checkAlt :: HsAlt -> P HsAlt
checkAlt (HsAlt loc p galts bs) = do
galts <- checkGAlts galts
return (HsAlt loc p galts bs)
checkGAlts :: HsRhs -> P HsRhs
checkGAlts (HsUnGuardedRhs e) = check1Expr e HsUnGuardedRhs
checkGAlts (HsGuardedRhss galts) = do
galts <- mapM checkGAlt galts
return (HsGuardedRhss galts)
checkGAlt :: HsGuardedRhs -> P HsGuardedRhs
checkGAlt (HsGuardedRhs loc e1 e2) = check2Exprs e1 e2 (HsGuardedRhs loc)
checkStmt :: HsStmt -> P HsStmt
checkStmt (HsGenerator loc p e) = check1Expr e (HsGenerator loc p)
checkStmt (HsQualifier e) = check1Expr e HsQualifier
checkStmt s@(HsLetStmt _) = return s
checkField :: HsFieldUpdate -> P HsFieldUpdate
checkField (HsFieldUpdate n e) = check1Expr e (HsFieldUpdate n)
checkValDef :: SrcLoc -> HsExp -> HsRhs -> [HsDecl] -> P HsDecl
checkValDef srcloc lhs rhs whereBinds =
case isFunLhs lhs [] of
Just (f,es) -> do
ps <- mapM checkPattern es
return (HsFunBind [HsMatch srcloc f ps rhs whereBinds])
Nothing -> do
lhs <- checkPattern lhs
return (HsPatBind srcloc lhs rhs whereBinds)
isFunLhs :: HsExp -> [HsExp] -> Maybe (Name, [HsExp])
isFunLhs (HsInfixApp l (HsVar ( op)) r) es = Just (op, l:r:es)
isFunLhs (HsApp (HsVar ( f)) e) es = Just (f, e:es)
isFunLhs (HsApp (HsParen f) e) es = isFunLhs f (e:es)
isFunLhs (HsApp f e) es = isFunLhs f (e:es)
isFunLhs _ _ = Nothing
checkUnQual :: Name -> P Name
checkUnQual n = if isJust (getModule n) then fail "Illegal qualified name" else return n
checkPrec :: Integer -> P Int
checkPrec i | 0 <= i && i <= 9 = return (fromInteger i)
checkPrec i | otherwise = fail ("Illegal precedence " ++ show i)
mkRecConstrOrUpdate :: HsExp -> [HsFieldUpdate] -> P HsExp
mkRecConstrOrUpdate (HsCon c) fs = return (HsRecConstr c fs)
mkRecConstrOrUpdate e fs@(_:_) = return (HsRecUpdate e fs)
mkRecConstrOrUpdate _ _ = fail "Empty record update"
fixupHsDecls :: [HsDecl] -> [HsDecl]
fixupHsDecls (d@(HsFunBind matches):ds) = (HsFunBind newMatches) : fixupHsDecls different where
funName = matchName $ head matches
(same, different) = span (sameFun funName) (d:ds)
newMatches = collectMatches same
fixupHsDecls (d:ds) = d : fixupHsDecls ds
fixupHsDecls [] = []
matchName (HsMatch _sloc name _pats _rhs _whereDecls) = name
sameFun :: Name -> HsDecl -> Bool
sameFun name (HsFunBind matches@(_:_)) = name == (matchName $ head matches)
sameFun _ _ = False
doForeign :: Monad m => SrcLoc -> [Name] -> Maybe (String,Name) -> HsQualType -> m HsDecl
doForeign srcLoc names ms qt = ans where
ans = do
(mstring,vname@(nameParts -> (_,Nothing,cname)),names') <- case ms of
Just (s,n) -> return (Just s,n,names)
Nothing -> do
(n:ns) <- return $ reverse names
return (Nothing,n,reverse ns)
let f ["import","primitive"] cname = return $ HsForeignDecl srcLoc (FfiSpec (Import cname mempty) Safe Primitive) vname qt
f ["import","dotnet"] cname = return $ HsForeignDecl srcLoc (FfiSpec (Import cname mempty) Safe DotNet) vname qt
f ("import":rs) cname = do
let (safe,conv) = pconv rs
im <- parseImport conv mstring vname
conv <- return (if conv == CApi then CCall else conv)
return $ HsForeignDecl srcLoc (FfiSpec im safe conv) vname qt
f ("export":rs) cname = do
let (safe,conv) = pconv rs
return $ HsForeignExport srcLoc (FfiExport cname safe conv undefined undefined) vname qt
f _ _ = error "ParseUtils: bad."
f (map show names') (maybe cname id mstring) where
pconv rs = g Safe CCall rs where
g _ cc ("safe":rs) = g Safe cc rs
g _ cc ("unsafe":rs) = g Unsafe cc rs
g _ cc ("jhc_context":rs) = g JhcContext cc rs
g s _ ("ccall":rs) = g s CCall rs
g s _ ("capi":rs) = g s CApi rs
g s _ ("stdcall":rs) = g s StdCall rs
g s c [] = (s,c)
g _ _ rs = error $ "FrontEnd.ParseUtils: unknown foreign flags " ++ show rs
doForeignEq :: Monad m => SrcLoc -> [Name] -> Maybe (String,Name) -> HsQualType -> HsExp -> m HsDecl
doForeignEq srcLoc names ms qt e = undefined
parseExport :: Monad m => String -> Name -> m String
parseExport cn hn =
case words cn of
[x] | isCName x -> return x
[] -> return (show hn)
_ -> fail ("Invalid cname in export declaration: "++show cn)
parseImport :: Monad m => CallConv -> Maybe String -> Name -> m FfiType
parseImport _ Nothing hn = return $ Import (show hn) mempty
parseImport cc (Just cn) hn =
case words cn of
["dynamic"] -> return Dynamic
["wrapper"] -> return Wrapper
[] -> return $ Import (show hn) mempty
("static":xs) -> parseIS cc xs
xs -> parseIS cc xs
parseIS cc rs = f Set.empty rs where
f s ['&':n] | isCName n = return $ ImportAddr n $ Requires s
f s [n] | isCName n = return $ Import n $ Requires s
f s ["&",n] | isCName n = return $ ImportAddr n $ Requires s
f s (i:r) = f (Set.insert (cc,packString i) s) r
f s x = fail ("Syntax error parsing foreign import: "++show x)
isCName [] = False
isCName (c:cs) = p1 c && all p2 cs
where p1 c = isAlpha c || any (c==) oa
p2 c = isAlphaNum c || any (c==) oa
oa = "_-$"
collectMatches :: [HsDecl] -> [HsMatch]
collectMatches [] = []
collectMatches (d:ds)
= case d of
(HsFunBind matches) -> matches ++ collectMatches ds
_anythingElse -> collectMatches ds
readInteger :: String -> Integer
readInteger ('0':'o':ds) = readInteger2 8 isOctDigit ds
readInteger ('0':'x':ds) = readInteger2 16 isHexDigit ds
readInteger ds = readInteger2 10 isDigit ds
readInteger2 :: Integer -> (Char -> Bool) -> String -> Integer
readInteger2 radix _ ds = foldl1 (\n d -> n * radix + d) (map (fromIntegral . digitToInt) ds)
readRational :: String -> Rational
readRational xs = (readInteger (i++m))%1 * 10^^(case e of {[] -> 0; ('+':e2) -> read e2; _ -> read e} length m)
where (i,r1) = span isDigit xs
(m,r2) = span isDigit (dropWhile (=='.') r1)
e = dropWhile (=='e') r2