{- ---------------------------------------------------------------------------}
{- |
Small tweaks based on type information.
optimisation: evaluation of `fromInteger' where possible
Also removes data constructors defined by newtype.
-}
module FixSyntax(fixSyntax) where
import qualified Data.Map as Map
import Maybe
import Syntax
import IdKind(IdKind(..))
import State
import IntState(IntState,lookupIS,tidIS,strIS)
import TokenId
import Info(isData,isMethod,tidI)
import FSLib(FSMonad,startfs,fsState,fsTidFun,fsExpAppl,fsClsTypSel,fsExp2,fsId
,fsRealData,fsList,ExpList)
import Ratio
import Machine
import Id(Id)
import NT(NT(..))
litFloatInteger :: a {-boxed-} -> Integer -> Lit a
litFloatInteger b v = LitFloat b (fromInteger v)
litFloatRational :: a {-boxed-} -> Ratio Integer -> Lit a
litFloatRational b v = LitFloat b (fromRational v)
-- | main function of this pass
fixSyntax :: Decls Id
-> IntState
-> ((TokenId,IdKind) -> Id)
-> ([Decl Id] -- modified declarations
,IntState -- modified internal state
,Map.Map TokenId Id)
fixSyntax topdecls state tidFun =
startfs fsTopDecls topdecls state tidFun
fsTopDecls :: Decls Id -> FSMonad [Decl Id]
fsTopDecls (DeclsScc depends) =
unitS (concat :: ([[Decl Id]] -> [Decl Id])) =>>>
-- concat must be typed for hbc ?
mapS fsTopDepend depends
fsTopDepend :: DeclsDepend Id -> FSMonad [Decl Id]
fsTopDepend (DeclsNoRec d) = fsDecl d >>>= \ d -> unitS [d]
fsTopDepend (DeclsRec ds) = mapS fsDecl ds
fsDecls :: Decls Id -> FSMonad (Decls Id)
fsDecls (DeclsScc depends) = unitS DeclsScc =>>> mapS fsDepend depends
fsDepend :: DeclsDepend Id -> FSMonad (DeclsDepend Id)
fsDepend (DeclsNoRec d) = unitS DeclsNoRec =>>> fsDecl d
fsDepend (DeclsRec ds) = unitS DeclsRec =>>> mapS fsDecl ds
fsDecl :: Decl Id -> FSMonad (Decl Id)
fsDecl d@(DeclPrimitive pos fun arity t) =
unitS d
fsDecl d@(DeclForeignImp pos _ _ fun arity cast t _) =
unitS d
fsDecl d@(DeclForeignExp pos _ _ fun t) =
unitS d
fsDecl (DeclFun pos fun funs) =
unitS (DeclFun pos fun) =>>> mapS fsFun funs
fsDecl (DeclPat (Alt pat rhs decls)) =
fsPat pat >>>= \ pat ->
fsRhs rhs >>>= \ rhs ->
fsDecls decls >>>= \ decls ->
unitS (DeclPat (Alt pat rhs decls))
fsFun :: Fun Id -> FSMonad (Fun Id)
fsFun (Fun pats rhs decls) =
mapS fsPat pats >>>= \ pats ->
fsRhs rhs >>>= \ rhs ->
fsDecls decls >>>= \ decls ->
unitS (Fun pats rhs decls)
fsRhs :: Rhs Id -> FSMonad (Rhs Id)
fsRhs (Unguarded e) = fsExp False e >>>= \e -> unitS (Unguarded e)
fsRhs (PatGuard gdexps) =
mapS fsPatGdExp gdexps >>>= \gdexps -> unitS (PatGuard gdexps)
fsPatGdExp :: ([Qual Id],Exp Id) -> FSMonad ([Qual Id],Exp Id)
fsPatGdExp (qs,e) =
mapS fsQual qs >>>= \ qs ->
fsExp False e >>>= \ e ->
unitS (qs,e)
fsQual :: Qual Id -> FSMonad (Qual Id)
fsQual (QualExp e) = fsExp False e >>>= unitS . QualExp
fsQual (QualPatExp p e) = fsPat p >>>= \p->
fsExp False e >>>= unitS . QualPatExp p
fsQual (QualLet ds) = fsDecls ds >>>= unitS . QualLet
-- | fsPat is exactly like fsExp, except that dictionary selectors with
-- a statically known dict are not compiled away. (Need to keep them
-- for e.g. numeric pattern-matching.)
fsPat :: Exp Id -> FSMonad (Exp Id)
fsPat exp = fsExp True exp
-- | fsExp takes a boolean argument, indicating whether we are in a pattern
-- (True) or in an expression (False).
fsExp :: Bool -> Exp Id -> FSMonad (Exp Id)
fsExp _ (ExpLambda pos pats exp) =
mapS fsPat pats >>>= \ pats ->
fsExp False exp >>>= \ exp ->
unitS (ExpLambda pos pats exp)
fsExp _ (ExpLet pos decls exp) =
fsDecls decls >>>= \ decls ->
fsExp False exp >>>= \ exp ->
unitS (ExpLet pos decls exp)
fsExp k (ExpDict exp) =
fsExp k exp >>>= \ exp ->
unitS (ExpDict exp)
fsExp _ (ExpCase pos exp alts) =
unitS (ExpCase pos) =>>> fsExp False exp =>>> mapS fsAlt alts
fsExp _ (ExpIf pos c e1 e2) =
unitS (ExpIf pos) =>>> fsExp False c =>>> fsExp False e1 =>>> fsExp False e2
fsExp k exp@(ExpApplication _ _) =
fsExp' k exp
---
--- No ExpList anymore
---
fsExp k (ExpList pos es) =
mapS (fsExp k) es >>>= \ es ->
fsList >>>= \ (nil,cons,_,_) ->
unitS (foldr (\ h t -> ExpApplication pos [cons,h,t]) nil es)
--- Change con into (con)
fsExp k e@(ExpCon pos ident) = fsExp k (ExpApplication pos [e])
--- Change Char into Int
--fsExp _ (ExpLit pos (LitChar b i)) = unitS (ExpLit pos (LitInt b (fromEnum i)))
fsExp _ (Exp2 pos i1 i2) = fsExp2 pos i1 i2
fsExp _ (PatAs pos i pat) = unitS (PatAs pos i) =>>> fsPat pat
fsExp _ (PatIrrefutable pos pat) = unitS (PatIrrefutable pos) =>>> fsPat pat
-- Change typeRep into something that builds the type
fsExp _ (ExpTypeRep pos nt) =
fsList >>>= \ list ->
fsState >>>= \ state ->
unitS $ makeTypeRep pos list state nt
fsExp _ e = unitS e
makeTypeRep :: Pos -> ExpList -> IntState -> NT -> Exp Id
makeTypeRep pos (eNil,eCons,eTyCon,eTyGen) state nt = rep (deTypeType nt)
where
deTypeType (NTcons _ _ [t]) = t
rep (NTvar i kind) =
case lookupIS state i of
Just info -> tyCon (show (tidI info)) []
Nothing -> tyGen $ 'v':(show i)
rep (NTapp x y) = app (rep x) (rep y)
rep (NTstrict _) = error "rep: NTstrict"
rep (NTcons i k xs) =
let iStr = strIS state i
in tyCon iStr (map rep xs)
rep (NTexist _ _) = error "rep: NTexists"
rep (NTany _) = error "rep: NTany"
rep _ = error "rep: ???"
foldAp [nt] = rep nt
foldAp (x:xs) =
let xs' = foldAp xs
in app (rep x) xs'
app x y = ExpApplication pos [eTyCon, string "Prelude.->", list [x, y]]
tyCon s ts = ExpApplication pos [eTyCon, string s, list ts]
tyGen s = ExpApplication pos [eTyGen, string s]
string s = ExpLit pos (LitString Boxed s)
list [] = eNil
list (x:xs) = ExpApplication pos [eCons, x, list xs]
-- | Auxiliary for fsExp guaranteed to get ExpApplications only.
fsExp' k (ExpApplication pos (ExpApplication _ xs:ys)) =
fsExp' k (ExpApplication pos (xs++ys))
--- fromInteger {Int Integer Float Double} constant
fsExp' k exp@(ExpApplication pos [v@(ExpVar _ qfromInteger)
,(ExpDict v2@(Exp2 _ qNum qType))
,l@(ExpLit pl (LitInteger b i))]) =
fsState >>>= \ state ->
if tidIS state qfromInteger == tfromInteger && tidIS state qNum == tNum
then if tidIS state qType == tInt
&& not (k && (abs(i)>32767)) then unitS (ExpLit pl (LitInt b (fromInteger i)))
else if tidIS state qType == tIntHash then unitS (ExpLit pl (LitInt UnBoxed (fromInteger i)))
else if tidIS state qType == tInteger then unitS l
else if tidIS state qType == tFloat then unitS (ExpLit pl (litFloatInteger b i))
else if tidIS state qType == tFloatHash then unitS (ExpLit pl (litFloatInteger UnBoxed i))
else if tidIS state qType == tDouble then unitS (ExpLit pl (LitDouble b (fromInteger i)))
else if tidIS state qType == tDoubleHash then unitS (ExpLit pl (LitDouble UnBoxed (fromInteger i)))
else if tidIS state qType == tRational then unitS (ExpLit pl (LitRational b (fromInteger i)))
else fsExp' k (ExpApplication pos [v,ExpDict (ExpApplication pos [v2]),l]) -- Match (sel (class.type dicts) args)
else fsExp' k (ExpApplication pos [v,ExpDict (ExpApplication pos [v2]),l])
--- fromRational {Float Double Rational} constant
fsExp' k (ExpApplication pos [v@(ExpVar _ qfromRational)
,(ExpDict v2@(Exp2 _ qFractional qType))
,l@(ExpLit pl (LitRational b i))]) =
fsState >>>= \ state ->
fsTidFun >>>= \ tidFun ->
-- strace (strPos pos++": normal literal Rational expr/pat\n") $
if tidIS state qfromRational == tfromRational && tidIS state qFractional == tFractional
then
if tidIS state qType == tFloat then unitS (ExpLit pl (litFloatRational b i))
else if tidIS state qType == tFloatHash then unitS (ExpLit pl (litFloatRational UnBoxed i))
else if tidIS state qType == tDouble then unitS (ExpLit pl (LitDouble b (fromRational i)))
else if tidIS state qType == tDoubleHash then unitS (ExpLit pl (LitDouble UnBoxed (fromRational i)))
else if tidIS state qType == tRational then {- let ratioFun = ExpVar pl (tidFun (tRatioCon,Var))
qIntegral = tidFun (tIntegral,TClass)
dict = ExpDict (Exp2 pl qFractional qIntegral)
num = ExpLit pl (LitInteger b (numerator i))
denom = ExpLit pl (LitInteger b (denominator i))
in unitS (ExpApplication pl [dict, num, denom]) -}
unitS l -- results in a nasty hack in Case
else fsExp' k (ExpApplication pos [v,ExpDict (ExpApplication pos [v2]),l]) -- Match (sel (class.type dicts) args)
else fsExp' k (ExpApplication pos [v,ExpDict (ExpApplication pos [v2]),l])
--- negate {Int Integer Float Double Rational} constant
fsExp' k (ExpApplication pos [v@(ExpVar pos3 qnegate)
,d@(ExpDict v2@(Exp2 _ qNum qType))
,p]) =
fsState >>>= \ state ->
if tidIS state qnegate == tnegate && tidIS state qNum == tNum then
fsExp k p >>>= \ p ->
case p of
ExpLit pos (LitInt b i) -> unitS (ExpLit pos (LitInt b (-i)))
ExpLit pos (LitInteger b i) -> unitS (ExpLit pos (LitInteger b (-i)))
ExpLit pos (LitFloat b i) -> unitS (ExpLit pos (LitFloat b (-i)))
ExpLit pos (LitDouble b i) -> unitS (ExpLit pos (LitDouble b (-i)))
ExpLit pos (LitRational b i) -> unitS (ExpLit pos (LitRational b (-i)))
-- negate (fromInteger v) in a pattern is a special case:
-- If the fromInteger was not elided in the recursive call
-- (e.g. instance Num UserType) then we need to keep the dictionary
-- for later, when we lookup the (==) method to match the pattern.
ExpApplication _ [ExpVar _ _,ExpLit _ _] ->
unitS (ExpApplication pos [v,d,p])
_ -> fsExp' k (ExpApplication pos [v,ExpDict (ExpApplication pos3 [v2]),p]) -- Will do p once more :-(
else
fsExp' k (ExpApplication pos [v,ExpDict (ExpApplication pos3 [v2]),p])
--
-- Transforms (sel class.type args) into (sel (class.type) args)
--
fsExp' k (ExpApplication pos (v@(ExpVar _ _):ExpDict v2@(Exp2 _ _ _):es)) =
fsExp' k (ExpApplication pos (v:ExpDict (ExpApplication pos [v2]):es))
-- Match (sel (class.type dicts) args)
--
-- Transforms (sel (class.type dicts) args) into ((class.type.sel dicts) args)
--
fsExp' k (ExpApplication pos (ExpVar sp sel
:ExpDict (ExpApplication ap (Exp2 _ cls qtyp:args))
:es)) =
fsState >>>= \ state ->
if (isMethod . fromJust . lookupIS state) sel &&
(isData . fromJust . lookupIS state) qtyp && not k then
fsClsTypSel sp cls qtyp sel >>>= \ fun ->
mapS (fsExp k) (args++es) >>>= \ args ->
fsExpAppl pos (fun:args)
else
fsExp2 ap cls qtyp >>>= \ fun ->
mapS (fsExp k) args >>>= \ args ->
fsExpAppl ap (fun:args) >>>= \ appl ->
mapS (fsExp k) es >>>= \ es ->
fsExpAppl pos (ExpVar sp sel : ExpDict appl :es)
{-
Check if data constructor is from newtype definition.
If it is, then remove it or replace it by the identity function.
-}
fsExp' k (ExpApplication pos (econ@(ExpCon cpos con):xs)) =
fsRealData con >>>= \ realdata ->
if realdata then
mapS (fsExp k) xs >>>= \ xs ->
fsExpAppl pos (econ:xs)
else
if length xs < 1 then
fsId -- because argument not available, have to replace by identity
else
mapS (fsExp k) xs >>>= \ xs ->
fsExpAppl pos xs
-- ABOVE
-- Can be an application if newtype is isomorphic to a function type
-- No! \[x] -> unitS x should do, but that doesn't matter.
---
--- Nothing to do
---
fsExp' k (ExpApplication pos xs) =
mapS (fsExp k) xs >>>= \ xs ->
fsExpAppl pos xs
fsAlt :: Alt Id -> FSMonad (Alt Id)
fsAlt (Alt pat rhs decls) =
fsPat pat >>>= \ pat ->
fsDecls decls >>>= \ decls ->
fsRhs rhs >>>= \ rhs ->
unitS (Alt pat rhs decls)
{- End FixSyntax ------------------------------------------------------------}
|
