{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
{- |
Module : ./Haskell/HatAna.hs
Description : calling programatica's analysis
Copyright : (c) Christian Maeder, Uni Bremen 2002-2006
License : GPLv2 or higher, see LICENSE.txt
Maintainer : Christian.Maeder@dfki.de
Stability : provisional
Portability : non-portable (multiple parameter class, functional dependency)
This module supplies a signature type and a type checking function
for the Haskell logic.
-}
module Haskell.HatAna (module Haskell.HatAna, PNT, TiDecl) where
import Haskell.HatParser hiding (hatParser)
import Haskell.PreludeString
import Common.AS_Annotation
import Common.Id (Pos (..), Range (..))
import Common.Result
import Common.GlobalAnnotations
import qualified Data.Map as Map
import qualified Data.Set as Set
import Common.Doc
import Common.DocUtils
import Common.ExtSign
import Data.List
import Data.Char
import qualified Data.Set as DSet
import Data.Maybe (fromMaybe)
type Scope = Rel (SN HsName) (Ent (SN String))
data Sign = Sign
{ instances :: [Instance PNT]
, types :: Map.Map (HsIdentI PNT) (Kind, TypeInfo PNT)
, values :: Map.Map (HsIdentI PNT) (Scheme PNT)
, scope :: Scope
, fixities :: Map.Map (HsIdentI (SN String)) HsFixity
} deriving Show
instance Eq Sign where
a == b = compare a b == EQ
instance Ord Sign where
compare a b = compare
( Map.keysSet $ types a, Map.keysSet $ values a, scope a
, Map.keysSet $ fixities a, length $ instances a)
( Map.keysSet $ types b, Map.keysSet $ values b, scope b
, Map.keysSet $ fixities b, length $ instances b)
diffSign :: Sign -> Sign -> Sign
diffSign e1 e2 = emptySign
{ instances = instances e1 \\ instances e2
, types = types e1 `Map.difference` types e2
, values = values e1 `Map.difference` values e2
, scope = scope e1 `minusRel` scope e2
, fixities = fixities e1 `Map.difference` fixities e2
}
addSign :: Sign -> Sign -> Sign
addSign e1 e2 = emptySign
{ instances = let is = instances e2 in (instances e1 \\ is) ++ is
, types = types e1 `Map.union` types e2
, values = values e1 `Map.union` values e2
, scope = scope e1 `DSet.union` scope e2
, fixities = fixities e1 `Map.union` fixities e2
}
isSubSign :: Sign -> Sign -> Bool
isSubSign e1 e2 = diffSign e1 e2 == emptySign
instance Eq (TypeInfo i) where
_ == _ = True
instance Eq (TiDecl PNT) where
a == b = compare a b == EQ
instance Ord (TiDecl PNT) where
compare a b = compare (show a) (show b)
instance Pretty (TiDecl PNT) where
pretty = text . pp
instance Pretty Sign where
pretty = printSign
printSign :: Sign -> Doc
printSign Sign { instances = is, types = ts,
values = vs, fixities = fs, scope = sc } =
text "{-" $+$ (if null is then empty else
text "instances:" $+$
vcat (map (text . pp . fst) is)) $+$
(if Map.null ts then empty else
text "\ntypes:" $+$
vcat (map (text . pp)
[ a :>: b | (a, b) <- Map.toList ts ])) $+$
(if Map.null vs then empty else
text "\nvalues:" $+$
vcat (map (text . pp)
[ a :>: b | (a, b) <- Map.toList vs ])) $+$
(if Map.null fs then empty else
text "\nfixities:" $+$
vcat [ text (pp b) <+> text (pp a)
| (a, b) <- Map.toList fs ]) $+$
text "\nscope:" $+$
text (pp sc) $+$
text "-}" $+$
text "module Dummy where"
extendSign :: Sign -> [Instance PNT]
-> [TAssump PNT]
-> [Assump PNT]
-> Scope
-> [(HsIdentI (SN String), HsFixity)]
-> Sign
extendSign e is ts vs s fs = addSign e emptySign
{ instances = is
, types = Map.fromList [ (a, b) | (a :>: b) <- ts ]
, values = Map.fromList [ (a, b) | (a :>: b) <- vs ]
, scope = s
, fixities = Map.fromList fs
}
emptySign :: Sign
emptySign = Sign
{ instances = []
, types = Map.empty
, values = Map.empty
, scope = emptyRel
, fixities = Map.empty
}
hatAna :: (HsDecls, Sign, GlobalAnnos) ->
Result (HsDecls, ExtSign Sign (), [Named (TiDecl PNT)])
hatAna (HsDecls hs, e, ga) = do
(decls, accSig, sens) <-
hatAna2 (HsDecls hs, addSign e preludeSign, ga)
return (decls, mkExtSign (diffSign accSig preludeSign), sens)
preludeSign :: Sign
preludeSign = case maybeResult $ hatAna2
(HsDecls preludeDecls, emptySign, emptyGlobalAnnos) of
Just (_, sig, _) -> sig
_ -> error "preludeSign"
hatAna2 :: (HsDecls, Sign, GlobalAnnos) ->
Result (HsDecls, Sign, [Named (TiDecl PNT)])
hatAna2 (hs@(HsDecls ds), e, _) = do
let parsedMod = HsModule loc0 (SN mod_Prelude loc0) Nothing [] ds
astMod = toMod parsedMod
insc = inscope astMod (const emptyRel)
osc = scope e `DSet.union` insc
expScope :: Rel (SN String) (Ent (SN String))
expScope = mapDom (fmap hsUnQual) osc
wm :: WorkModuleI QName (SN String)
wm = mkWM (osc, expScope)
fixs = mapFst getQualified $ getInfixes parsedMod
fixMap = Map.fromList fixs `Map.union` fixities e
rm = reAssocModule wm [(mod_Prelude, Map.toList fixMap)] parsedMod
(HsModule _ _ _ _ sds, _) =
scopeModule (wm, [(mod_Prelude, expScope)]) rm
ent2pnt (Ent m (HsCon i) t) =
HsCon (topName Nothing m (bn i) (origt m t))
ent2pnt (Ent m (HsVar i) t) =
HsVar (topName Nothing m (bn i) (origt m t))
bn = getBaseName
origt m = fmap (osub m)
osub m n = origName n m n
findPredef ns (_, n) =
case filter ((== ns) . namespace) $ applyRel expScope (fakeSN n) of
[v] -> Right (ent2pnt v)
_ -> Left ("'" ++ n ++ "' unknown or ambiguous")
inMyEnv = withStdNames findPredef
. inModule (const mod_Prelude) []
. extendts [ a :>: b | (a, b) <- Map.toList $ values e ]
. extendkts [ a :>: b | (a, b) <- Map.toList $ types e ]
. extendIEnv (instances e)
case sds of
[] -> return ()
d : _ -> Result [Diag Hint ('\n' : pp sds)
(Range [formSrcLoc $ srcLoc d])] $ Just ()
fs :>: (is, (ts, vs)) <-
lift $ inMyEnv $ tcTopDecls id sds
let accSign = extendSign e is ts vs insc fixs
return (hs, accSign, map (makeNamed "") $ fromDefs
(fs :: TiDecls PNT))
-- filtering some Prelude stuff
formSrcLoc :: SrcLoc -> Pos
formSrcLoc (SrcLoc file _ line col) = SourcePos file line col
getHsDecl :: (Rec a b, GetBaseStruct b (DI i e p ds t [t] t)) =>
a -> DI i e p ds t [t] t
getHsDecl = Data.Maybe.fromMaybe (HsFunBind loc0 []) . basestruct . struct
-- use a dummy for properties
preludeConflicts :: [HsDecl] -> ([HsDecl], [Diagnosis])
preludeConflicts =
foldr ( \ d (es, ds) -> let e = getHsDecl d
p = [formSrcLoc $ srcLoc e]
in
if preludeEntity e then
(es,
Diag Warning ("possible Prelude conflict:\n " ++ pp e)
(Range p) : ds)
else (d : es, ds)) ([], [])
preludeEntity :: (Printable i, Show t, DefinedNames i t) =>
DI i e p ds t [t] t -> Bool
preludeEntity d = case d of
HsFunBind _ ms -> any preludeMatch ms
HsTypeSig _ ts _ _ -> any (flip Set.member preludeValues . pp) ts
HsTypeDecl _ ty _ -> Set.member (pp $ definedType ty) preludeTypes
HsDataDecl _ _ ty cs _ -> Set.member (pp $ definedType ty) preludeTypes
|| any preludeConstr cs
HsInstDecl {} -> False
HsClassDecl {} -> False -- should not be a prelude class
_ -> True -- ignore others
preludeMatch :: Printable i =>
HsMatchI i e p ds -> Bool
preludeMatch m = case m of
HsMatch _ n _ _ _ -> let s = pp n in
Set.member s preludeValues || prefixed s
preludeConstr :: Printable i => HsConDeclI i t [t] -> Bool
preludeConstr c = let s = pp $ case c of
HsConDecl _ _ _ n _ -> n
HsRecDecl _ _ _ n _ -> n
in Set.member s preludeConstrs
genPrefixes :: [String]
genPrefixes = ["$--", "default__", "derived__Prelude", "inst__Prelude"]
prefixed :: String -> Bool
prefixed s = any (`isPrefixOf` s) genPrefixes
preludeValues :: Set.Set String
preludeValues = Set.fromList $ filter (not . prefixed) $ map pp
$ Map.keys $ values preludeSign
preludeConstrs :: Set.Set String
preludeConstrs =
Set.filter ( \ s -> not (null s) && isUpper (head s)) preludeValues
preludeTypes :: Set.Set String
preludeTypes = Set.fromList $ map pp $ Map.keys $ types preludeSign