{- ---------------------------------------------------------------------------
Builds the contents of the interface file
-}
module Export(Flags,PackedString,IntState,buildInterface) where
import List
import NT
import IntState hiding (InfixClass)
import Scc
import qualified Data.Map as Map
import qualified Data.Set as Set
import Util.Extra
import TokenId
import SysDeps(PackedString,unpackPS)
import Syntax(InfixClass(..))
import Nice
import IExtract(defFixity)
import Flags(Flags, sPrelude)
import Maybe
import Building (Compiler(..),compiler)
--import NonStdProfile -- only for debugging the compiler
profile a b = b
{- Build the contents of the interface file -}
buildInterface :: Flags -> PackedString -> IntState -> String
buildInterface flags modidl state =
strExport modidl state (export flags state)
{- Collect the information that has to go into the interface file. -}
export :: Flags
-> IntState
-> ([(TokenId,(InfixClass TokenId,Int))],[(Bool,[Info])])
export flags state =
let symbols = map snd . Map.toList . getSymbolTable
infoExport = (filter (isExported . expI) . symbols) state
insts = let hereCls = filter isClass (symbols state)
usedCls = filter isUsedClass (symbols state)
in
foldr (\(InfoClass unique tid exp nt ms ds insts) r ->
foldr (fixInst state (sPrelude flags || notPrelude tid)
unique)
r (Map.toList insts))
[] hereCls
++
foldr (\(InfoUsedClass unique _ insts) r ->
foldr (fixInst state (sPrelude flags) unique)
r (Map.toList insts))
[] usedCls
in case uniqueISs state insts of
(insts,state) ->
let
(infoInst,depInst) =
unzip (map (\((mrps,cls,nt,dep),i) -> (InfoInstance i mrps nt cls,(i,dep)))
insts)
depExport = map infoDepend infoExport
depExtra = profile "getAll start"
(getAll state
(foldr (Set.insert) Set.empty (map fst depExport))
(concatMap snd depExport ++ concatMap snd depInst))
depend = reverse $ profile "start sccDepend"
$ sccDepend (depExport ++ depExtra ++ depInst)
expTree = foldr (\info tree -> Map.insert (uniqueI info) info tree)
Map.empty
(infoInst++infoExport)
declExport = (map (\xs -> if all isLeft xs
then (False,map dropLeft xs)
else (True,map dropEither xs)
-- !!! Not good, more is exported than should have been
)
. filter (not . null)
. map (fixInfo (sPrelude flags) state expTree)
) depend
infExport = filter ( (/=defFixity) . snd)
(concatMap (concatMap getFixity . snd)
(filter fst declExport))
getFixity :: Info -> [(TokenId,(InfixClass TokenId,Int))]
getFixity (InfoData unique tid IEall nt dk) =
case dk of
Data unboxed constrs ->
map ( (\info-> (tidI info, fixityI info))
. fromJust . lookupIS state)
constrs
_ -> []
getFixity (InfoData unique tid IEsome nt dk) =
case dk of
Data unboxed constrs ->
concatMap ( (\info-> case expI info of
IEsel -> [(tidI info,fixityI info)]
_ -> [] )
. fromJust . lookupIS state)
constrs
_ -> []
getFixity (InfoData unique tid _ nt dk) = []
getFixity (InfoClass unique tid ie nt ms ds insts) =
map ( (\info -> (tidI info,fixityI info)) . fromJust . lookupIS state)
ms
getFixity (InfoVar unique tid ie fix nt annot) = [(tid,fix)]
getFixity (InfoInstance unique mrps nt iClass) = []
getFixity (InfoConstr unique tid ie fix nt fields iType) = []
getFixity x = error ("getFixity = " ++ show x)
in
(infExport,declExport)
where
getAll state found [] = profile "getAll end" []
getAll state found (u:us) =
if u `Set.member` found
then getAll state found us
else
case (infoDepend . fromJust . lookupIS state) u of
depend@(u,dep) -> depend : getAll state (Set.insert u found) (dep ++ us)
infoDepend (InfoData unique tid exp nt dk) =
case dk of
(DataTypeSynonym unboxed depth) -> (unique, useNewType nt)
(DataNewType unboxed constructors) -> dataDepend exp nt constructors
(DataPrimitive size) -> (unique, useNewType nt)
(Data unboxed constrs) -> dataDepend exp nt constrs
where
dataDepend exp nt constrs =
if exp == IEabs then
(unique, useNewType nt)
else (unique, snub (useNewType nt
++ concatMap (useConstr . lookupIS state) constrs))
infoDepend (InfoClass unique tid ie nt ms ds insts)
| ie==IEall || ie==IEsome =
(unique, snub (useNewType nt
++ concatMap (useMethod . lookupIS state) ms))
infoDepend (InfoClass unique tid _ nt ms ds insts) =
(unique, snub (useNewType nt))
infoDepend (InfoUsedClass unique _ insts) = -- MW
(unique, []) -- MW
infoDepend (InfoVar unique tid ie fix nt annot) =
(unique, useNewType nt)
infoDepend (InfoConstr unique tid ie fix nt fields iType) =
(unique, useNewType nt)
infoDepend (InfoUsed unique _) =
(unique, [])
infoDepend info = error ("infoDepend " ++ show info)
fixInst state keep unique (con,(rps,free,ctxs)) r =
if keep || (notPrelude . tidI . fromJust . lookupIS state) con then
( rps
, unique
, NewType free [] ctxs [mkNTcons con (map mkNTvar free)]
, snub (con:map fst ctxs)
):r
else
r
fixInfo keep state ds (NoRec n) = fixInfo' keep state ds n
fixInfo keep state ds (Rec ns) = concatMap (fixInfo' keep state ds) ns
fixInfo' keep state ds n =
case Map.lookup n ds of
Just info -> [Right info]
Nothing ->
case lookupIS state n of
Just info ->
if (keep || notPrelude (tidI info))
then [Left info]
else []
useNewType (NewType free exist ctxs nts) =
snub (map fst ctxs ++ (concatMap useNT nts))
useConstr (Just (InfoConstr unique tid ie fix nt fields iType)) = useNewType nt
useMethod (Just (InfoMethod unique tid ie fix nt annot iClass)) = useNewType nt
useMethod x = error ("No match in useMethod:" ++ show x)
{- Create content of interface file. -}
strExport :: PackedString -- module name
-> IntState
-> ([(TokenId,(InfixClass TokenId,Int))],[(Bool,[Info])])
-> String
strExport modidl state (fixs,exps) =
( showString ("interface " ++ reverse (unpackPS modidl) ++ " where {\n")
. foldr ((.).showsFix modrps) id fixs
. foldr ((.).showsHide modrps) id
(optExport False Nothing (map preExport exps))
) "}\n"
where
modrps = mrpsIS state
preExport (visible,infos@(InfoInstance u mrps nt iClass:_)) =
((visible,Nothing),infos)
preExport (visible,infos@(info:_)) =
case (extractM . tidI) info of
rps -> ((visible,Just rps),infos)
optExport preV preRps [] = []
optExport preV preRps (((v,rps),infos):xs) =
(preV == v && preRps == rps,v,rps,infos) : optExport v rps xs
showsFix :: PackedString
-> (TokenId,(InfixClass TokenId,Int))
-> String -> String
showsFix mrps (tid,(InfixPre i,l)) =
showString "prefix ". niceTid state i . showChar ' ' . shows l
. showChar ' ' . showsOp (fixTid mrps tid) . showString ";\n"
showsFix mrps (tid,(InfixDef ,l)) = id
showsFix mrps (tid,(inf,l)) =
shows inf . showChar ' ' . shows l
. showChar ' ' . showsOp (fixTid mrps tid) . showString ";\n"
showsHide :: a
-> (Bool,Bool,Maybe PackedString,[Info])
-> String -> String
showsHide mrps (prev,visible,rps,infos) =
-- Would have prefered not to use qualified names, but have to
(if prev || isNothing rps
then id
else (if visible
then showString "interface ! "
else showString "interface ")
. (showString . reverse . unpackPS . fromJust) rps)
. showString "\n{-# NEED"
. foldr ((.).showsNeed (fromJust rps)) id infos
. showString " #-}\n"
-- need does not need to be qualified
. foldr ((.).showsInfo (fromJust rps)) id infos
-- but the definitions must
-- Hack for tuples
showsNeed mrps (InfoData unique (TupleId n) exp nt dk) =
showString " {" . pat . showChar ' ' . pat . showChar '}'
where
pat = showChar '(' . commas . showChar ')'
commas = if n == 0 then id
else foldr (.) id (replicate (n-1) (showChar ','))
-- Always look in tuple definitions
showsNeed mrps (InfoData unique tid exp nt dk) =
case dk of
(DataNewType unboxed constructors) ->
groupNeed mrps exp tid constructors
(Data unboxed constrs) -> groupNeed mrps exp tid constrs
_ -> showChar ' ' . showsVar (fixTid mrps tid)
showsNeed mrps (InfoClass unique tid exp nt ms ds insts) =
groupNeed mrps exp tid ms
showsNeed mrps (InfoVar unique tid exp fix nt annot) =
showChar ' '.showsVar (fixTid mrps tid)
showsNeed mrps (InfoConstr unique tid ie fix nt fields iType)
| ie==IEsel = showChar ' '. showsVar (fixTid mrps tid)
. foldr ((.) . showsField mrps) id fields
| otherwise = foldr ((.) . showsField mrps) id fields
showsNeed mrps (InfoMethod unique tid ie fix nt annot iClass)
| ie==IEsel = showChar ' ' . showsVar (fixTid mrps tid)
| otherwise = id
showsNeed mrps (InfoInstance _ _ _ _) = id
showsNeed mrps (InfoUsedClass _ _ _) = id
showsNeed mrps (InfoUsed _ _) = id
groupNeed mrps ie group parts
| (ie==IEall || ie==IEsome) && not (null parts) =
showString " {" . showsVar (fixTid mrps group)
. foldr ((.) . showsNeed mrps . fromJust . lookupIS state)
id parts
. showChar '}'
groupNeed mrps ie group parts =
showChar ' ' . showsVar (fixTid mrps group)
showsField mrps Nothing = id
showsField mrps (Just i) = showChar ' ' . shows (fixTid mrps (tidIS state i))
-- Hack for tuples
showsInfo mrps (InfoData unique (TupleId nargs) exp
nt@(NewType free exist ctxs nts) dk) =
let arg = mkAL free
al = arg ++ zip (map snd ctxs) (map (('_':).(:[])) ['a'..'z'])
-- a-z is too short!
strNewType = niceCtxs Nothing state al ctxs
++ mixSpace (map (niceNT Nothing state al) nts)
strArgs = concatMap ((' ':).snd) arg
strTuple = if nargs > 0 then take nargs ('(':repeat ',') ++ ")"
else "()"
in
case dk of
(DataTypeSynonym unboxed depth) ->
showString "type {-# " . shows depth
. (if unboxed then showString " !" else id) . showString " #-} "
. showString strTuple . showString strArgs . showString " = "
. showString strNewType . showString ";\n"
(DataNewType unboxed constrs) ->
showString "newtype {-# "
. (if unboxed then showChar '!' else id) . showString " #-} "
. showString (niceCtxs Nothing state al ctxs)
. showString strTuple . showString strArgs
. (if exp==IEall && not (null constrs) then
showString "\n = "
. showString (mix "\n | "
(map (expConstr mrps al . lookupIS state)
constrs))
else id)
. showString ";\n"
(DataPrimitive size) ->
if nargs == 0 then
showString "data primitive () = " . shows size . showString ";\n"
else
error ("showsInfo in Export cannot handle primitive TupleID with "
++ show nargs ++ " arguments.")
(Data unboxed constrs) ->
showString ("data " ++ (if unboxed then "unboxed " else "")
++ niceCtxs (Just mrps) state al ctxs)
. showString strTuple . showString strArgs
. (if exp == IEall && not (null constrs) then
showString "\n = "
. showString (mix "\n | "
(map (expConstr mrps al . lookupIS state)
constrs))
else id)
. showString ";\n"
showsInfo mrps (InfoData unique tid exp nt@(NewType free exist ctxs nts) dk) =
let arg = mkAL free
al = arg ++ zip (map snd ctxs) (map (('_':).(:[])) ['a'..'z'])
-- a-z is too short!
strNewType = niceCtxs (Just mrps) state al ctxs
++ mixSpace (map (niceNT (Just mrps) state al) nts)
strArgs = concatMap ((' ':).snd) arg
in
case dk of
(DataTypeSynonym unboxed depth) ->
showString "type {-# " . shows depth
. (if unboxed then showString " !" else id) . showString " #-} "
. showsVar (fixTid mrps tid) . showString (strArgs ++ " = ")
. showString strNewType . showString ";\n"
(DataNewType unboxed constrs) ->
showString "newtype {-# "
. (if unboxed then showChar '!' else id) . showString " #-} "
. showString (niceCtxs Nothing state al ctxs)
. showsVar (fixTid mrps tid) . showString strArgs
. (if (exp==IEall || exp==IEsome) && not (null constrs) then
showString "\n = "
. showString (mix "\n | "
(map (expConstr mrps al . lookupIS state)
constrs))
else id)
. showString ";\n"
(DataPrimitive size) ->
showString "data primitive "
. showsVar (fixTid mrps tid) . showString " = " . shows size
. showString ";\n"
(Data unboxed constrs) ->
showString ("data " ++ (if unboxed then "unboxed " else "")
++ niceCtxs (Just mrps) state al ctxs)
. showsVar (fixTid mrps tid) . showString strArgs
. (if (exp==IEall || exp==IEsome) && not (null constrs) then
(showString "\n = "
. showString (mix "\n | "
(map (expConstr mrps al . lookupIS state)
constrs)))
else id)
. showString ";\n"
showsInfo mrps (InfoClass unique tid exp (NewType free exist ctxs nts)
ms ds insts) =
let al = mkAL free
in showString "class " . showString (niceCtxs Nothing state al ctxs)
. showsVar (fixTid mrps tid) . showString (concatMap ((' ':).snd) al)
. (if (exp==IEall || exp==IEsome) && not (null ms) then
showString " where {\n"
. showString (concatMap (expMethod mrps . lookupIS state) ms)
. showString "};\n"
else showString ";\n")
----
showsInfo mrps (InfoUsedClass unique ((_,tid,_,_):_) insts) = -- MW
showString "class " . showsVar (fixTid mrps tid) . showString (" a;\n")
showsInfo mrps (InfoUsed unique ((_,tid,_,_):_)) = id
-- showString "used " . showsVar (fixTid mrps tid) . showString (";\n")
----
showsInfo mrps (InfoVar unique tid exp fix nt annot) =
showsVar (fixTid mrps tid) . showsAnnot annot . showString "::"
. showString (niceNewType state nt) . showString ";\n"
showsInfo mrps (InfoInstance unique imrps (NewType free exist ctxs [nt]) iClass) =
let al = mkAL free
im = reverse $ unpackPS imrps
in showString "instance "
. ( if compiler==Yhc then showString im . showString " @ " else id )
. showString (niceCtxs Nothing state al ctxs)
. niceInt Nothing state iClass . showChar ' '
. showString (niceNT Nothing state al nt)
. showString ";\n"
showsInfo mrps (InfoConstr unique tid ie fix nt fields iType) = id
showsAnnot Nothing = id
showsAnnot (Just a) = showString "{-# " . shows a . showString " #-}"
expConstr mrps al (Just (InfoConstr unique (TupleId nargs) ie fix
(NewType free exist ctxs nts) field iType)) =
(showString (if nargs > 0 then take nargs ('(':repeat ',') ++ ") "
else "()"))
(mixSpace (map (niceField state al) (zip field (init nts))))
expConstr mrps al (Just (InfoConstr unique tid ie fix
(NewType free exist ctxs ectxs_nts) field iType)) =
-- al contains type variables to string mapping
-- exist contains existential type variables not in al
let exist' = zip exist (map (:"_fa") ['a'..'z']) -- a-z is too short!
al' = al ++ exist'
ectxs = map ntContext2Pair (filter contextNT ectxs_nts)
nts = filter (not . contextNT) ectxs_nts
in
(if null exist then ""
else "forall " ++ mixSpace (map snd exist') ++ " . ")
++ niceCtxs Nothing state al' ectxs
++ (showsVar (fixTid mrps tid) . showChar ' ')
(mixSpace (map (niceField state al') (zip field (init nts))))
expMethod :: PackedString -> Maybe Info -> String
expMethod mrps (Just (InfoMethod unique tid ie fix nt annot iClass)) =
(showString " " . showsVar (fixTid mrps tid) . showsAnnot annot
. showString "::" . showString (niceNewType state nt))
";\n"
|
