{- ---------------------------------------------------------------------------
Three functions for removing some syntactic sugar:
removeDecls: create selectors for record fields
mkSel: create a single selector for a named field
removeDo: remove do notation
translateExpRecord: remove record expressions
(patternmatching, construction and updating)
-}
module Remove1_3(removeDecls,mkSel,removeDo,translateExpRecord) where
import Syntax
import State
import IntState
import TokenId(t_gtgt,t_gtgteq,tfail,t_recConError)
import TokenInt
import Type.Lib(getState,newIdent,getIdent)
import SyntaxPos
import Type.Data(TypeMonad)
import IdKind
import Util.Extra(strPos,mixCommaAnd,noPos,dropRight,isRight)
import List
import Id(Id)
import Maybe
{- ---------------------------------------------------------------------------
Create selectors for record fields.
Done before strongly connected components analysis.
-}
type SelectorMonad a = State () ([Id],IntState,TidFun) a ([Id],IntState,TidFun)
-- () -> ([Id],IntState) -> (a,([Id],IntState))
type TidFun = (TokenId,IdKind) -> Id
{-
Replace DeclConstrs in the declarations by definitions for selectors.
Also collect identifiers of all field names.
-}
removeDecls :: Decls Id -> ((TokenId,IdKind) -> Id) -> IntState
-> (Decls Id -- modified declarations
,[Id] -- identifiers of all data constructors
,IntState)
removeDecls (DeclsParse decls) tidFun state =
case mapS removeDecl decls () ([],state,tidFun) of
(decls,(zcons,state,_)) -> (DeclsParse (concat decls),zcons,state)
{-
Replace a single DeclConstrs by definitions for selectors.
-}
removeDecl :: Decl Id -> SelectorMonad [Decl Id]
removeDecl (DeclConstrs pos zcon cs) =
remember zcon >>>= \_ ->
mapS mkSel cs
removeDecl d = unitS [d]
{-
Create the definition for a given selector identfier.
-}
mkSel :: (Pos -- point of definition of selector, i.e in type definition
,Id -- field name id
,Id) -- selector name id
-> SelectorMonad (Decl Id)
mkSel (pos,field,selector) =
r13Info field >>>= \ (InfoField unique tid ie icon_offs iData iSel) ->
mapS (mkFun pos) icon_offs >>>= \ alts ->
unitS (DeclFun pos selector alts)
{-
Make one equation of a selector for given data constructor and offset
-}
mkFun :: Pos
-> (Id,Int) -- (data constructor, offset)
-> SelectorMonad (Fun Id)
mkFun pos (c,i) =
r13Info c >>>= \ conInfo ->
r13Unique >>>= \ v ->
r13ModId >>>= \ mi ->
r13TidFun >>>= \ tidFun ->
let wildcard = PatWildcard pos {- ExpApplication pos [ExpVar noPos $ tidFun (t_recConError,Var),
ExpLit pos $
LitString Boxed $
mi ++ ": record field was never given a value " ++ strPos pos ++ "." ] -}
var = ExpVar pos v
vars = take (arityI conInfo) (repeat wildcard)
-- arityI safe for constructors :-)
in
unitS (Fun [ExpApplication pos (ExpCon pos c : onePos var i vars)]
(Unguarded var) (DeclsParse []))
{-
Replace list element at given index by given new element.
-}
onePos :: a -> Int -> [a] -> [a]
onePos v 1 (x:xs) = v:xs
onePos v n (x:xs) = x: onePos v (n-1 ::Int) xs
r13Info :: Id -> SelectorMonad Info
r13Info i down thread@(zcon,state,_) = (fromJust (lookupIS state i),thread)
{- get a new unique id -}
r13Unique :: SelectorMonad Id
r13Unique down thread@(zcon,state,tf) =
case uniqueIS state of
(u,state) -> (u,(zcon,state,tf))
r13ModId :: SelectorMonad String
r13ModId down thread@(zcon,state,_) = (getModuleId state,thread)
r13TidFun :: SelectorMonad TidFun
r13TidFun down thread@(_,_,tf) = (tf,thread)
remember :: Id -> SelectorMonad ()
remember zcon down thread@(zcons,state,tf) = ((),(zcon:zcons,state,tf))
{- ---------------------------------------------------------------------------
Remove syntactic sugar of do notation.
Done after strongly connected components analysis,
more precisely: called by type checker
-}
{-
Remove syntactic sugar of do notation.
-}
removeDo :: [Stmt Id] -> TypeMonad (Exp Id)
removeDo [StmtExp exp] = unitS exp
removeDo (StmtExp exp:r) =
let pos = getPos exp
in
getIdent (t_gtgt,Var) >>>= \ gtgt ->
removeDo r >>>= \ exp2 ->
unitS (ExpApplication pos [ExpVar pos gtgt, exp, exp2])
removeDo (StmtLet decls :r) =
let pos = getPos decls
in
removeDo r >>>= \ exp2 ->
unitS (ExpLet pos decls exp2)
removeDo (StmtBind pat exp:r) =
getIdent (t_gtgteq,Var) >>>= \ gtgteq ->
getState >>>= \ state ->
removeDo r >>>= \ exp2 ->
let pos = getPos exp
in
if nofail state pat
then
-- this is only an optimisation; the else-case is never wrong
unitS (ExpApplication pos [ExpVar pos gtgteq, exp, ExpLambda pos [pat] exp2])
else
getIdent (tfail,Var) >>>= \ fail ->
newIdent >>>= \ x ->
let eX = ExpVar pos x
eFail = ExpApplication pos [ExpVar pos fail
,ExpLit pos (LitString Boxed "pattern-match failure in do expression")]
in unitS
(ExpApplication pos
[ExpVar pos gtgteq
,exp
,ExpLambda pos [eX]
(ExpCase pos eX
[Alt pat (Unguarded exp2) (DeclsScc [])
,Alt (PatWildcard pos) (Unguarded eFail) (DeclsScc [])
])])
{-
Test if matching the given pattern cannot fail.
-}
nofail :: IntState -> Pat Id -> Bool
nofail state (ExpCon pos con) =
case lookupIS state con of
Just (InfoConstr unique tid ie fix nt fields iType) ->
case lookupIS state iType of
Just (InfoData unique tid exp nt dk) ->
case dk of
(DataNewType unboxed constructors) -> True
(Data unboxed constrs) -> length constrs == 1
nofail state (ExpVar _ _) = True
nofail state (ExpApplication pos es) = all (nofail state) es
nofail state (PatWildcard _) = True
nofail state (PatAs _ _ pat) = nofail state pat
nofail state (PatIrrefutable pos pat) = True
nofail state _ = False
{- ---------------------------------------------------------------------------
Remove record expressions.
Done after strongly connected components analysis,
more precisely: called by type checker
-}
fieldInfo :: IntState
-> Field Id
-> (Id -- type constructor
,([(Id,Int)] -- data constructors with offsets for field
,Exp Id)) -- expressions from "field=exp"
fieldInfo state (FieldExp pos field exp) =
case lookupIS state field of
Just (InfoField unique tid ie icon_offs idata iSel) -> (idata,(icon_offs,exp))
{- lookup value in association list; if not there, then return default value -}
fixArg :: Eq a => [(a,b)] -> (a,b) -> b
fixArg given (i,def) =
case lookup i given of
Just e -> e
Nothing -> def
{- construct alternative for record updating for one data constructor -}
fixAlt :: Pos
-> [Exp Id] -- arguments for offsets
-> (Id,[Int]) -- (data constructor, offsets)
-> IntState
-> (Alt Id,IntState)
fixAlt pos exps (con,offsets) state =
(Alt (ExpApplication pos (econ:vars))
(Unguarded
(ExpApplication pos
(econ : map (fixArg (zip offsets exps)) (zip nargs vars))))
(DeclsScc [])
,state')
where
nargs = [1 .. arityIS state con]
(newNIds,state') = uniqueISs state nargs
vars = map (ExpVar noPos . snd) newNIds
econ = ExpCon pos con
getOffsets :: [[(Id,Int)]] -> Id -> Either (Id,[Maybe Int]) (Id,[Int])
getOffsets icon_offs con =
let offsets = map (\ icon_off -> lookup con icon_off) icon_offs
in if all isJust offsets
then Right (con,map fromJust offsets)
else Left (con,offsets)
{-
Replace record expression exp{field1=exp1,...} by a non-record expression.
Used for record patterns as well.
(in fact, undefined constructor arguments are filled with wildcard patterns)
-}
translateExpRecord :: Exp Id -> [Field Id] -> IntState
-> (Either String (Exp Id),IntState)
translateExpRecord e@(ExpRecord exp' fields') fields state =
translateExpRecord exp' (fields ++ fields') state
translateExpRecord e@(ExpCon pos con) fields state =
let coes = map (fieldInfo state) fields
in if firstIsEqual coes
then
let (icon_offs,exps) = unzip (map snd coes)
in case getOffsets icon_offs con of
Right (con,offsets) ->
(Right (ExpApplication pos (e:map (fixArg (zip offsets exps))
(zip [1 .. arityIS state con]
(repeat (PatWildcard pos))
) ))
,state)
Left (con,offsets) ->
(Left (errField1 state pos con offsets fields)
,state)
else (Left (errField2 state fields),state)
translateExpRecord exp [] state =
(Left (errField4 (getPos exp)),state)
translateExpRecord exp fields state =
let coes@((t,_):_) = map (fieldInfo state) fields
in if firstIsEqual coes -- all fields belong to same data type
then
let (icon_offs,exps) = unzip (map snd coes)
pos = getPos exp
in case (partition isRight . map (getOffsets icon_offs) .
constrsI . fromJust . lookupIS state) t of
([],_) -> (Left (errField3 state fields),state)
(rps,_) -> let consFixAlt rps (alts,state) =
case fixAlt pos exps rps state of
(alt,state') -> (alt:alts,state')
(alts,state') = foldr consFixAlt ([],state)
(map dropRight rps)
in (Right (ExpCase (getPos exp) exp alts), state')
else (Left (errField2 state fields),state)
{- Test if all first components are equal. -}
firstIsEqual :: Eq a => [(a,b)] -> Bool
firstIsEqual [] = True
firstIsEqual ((k,_):kvs) = all (k==) (map fst kvs)
errField1 :: IntState -> Pos -> Id -> [Maybe a] -> [Field Id] -> String
errField1 state pos con offsets fields =
"The field(s)" ++
mixCommaAnd (map (\(_,FieldExp pos field exp) -> ' ':show (tidIS state field)
++ " at " ++ strPos pos)
(filter (isNothing.fst) (zip offsets fields)))
++ " do(es) not belong to constructor " ++ show (tidIS state con) ++
" used at " ++ strPos pos ++ "."
errField2 :: IntState -> [Field Id] -> String
errField2 state fields =
"The fields" ++
mixCommaAnd (map (\(FieldExp pos field exp) -> ' ': show (tidIS state field)
++ " at " ++ strPos pos)
fields)
++ " do not belong to the same type."
errField3 :: IntState -> [Field Id] -> String
errField3 state fields =
"The fields " ++
mixCommaAnd (map (\(FieldExp pos field exp) -> ' ':show (tidIS state field)
++ " at " ++ strPos pos)
fields)
++ " do not belong to the same constructor."
errField4 :: Pos -> [Char]
errField4 pos =
"The update of the expression at " ++ strPos pos ++
" uses an empty list of fields."
{- End Remove1_3 ------------------------------------------------------------}
|
