11N/A{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}

553N/A{- |

11N/AModule : ./Haskell/HatAna.hs

11N/ADescription : calling programatica's analysis

11N/ACopyright : (c) Christian Maeder, Uni Bremen 2002-2006

11N/ALicense : GPLv2 or higher, see LICENSE.txt

553N/A

11N/AMaintainer : Christian.Maeder@dfki.de

553N/AStability : provisional

11N/APortability : non-portable (multiple parameter class, functional dependency)

11N/A

11N/AThis module supplies a signature type and a type checking function

11N/Afor the Haskell logic.

11N/A-}

11N/A

11N/Amodule Haskell.HatAna (module Haskell.HatAna, PNT, TiDecl) where

11N/A

11N/Aimport Haskell.HatParser hiding (hatParser)

11N/Aimport Haskell.PreludeString

11N/A

553N/Aimport Common.AS_Annotation

553N/Aimport Common.Id (Pos (..), Range (..))

553N/Aimport Common.Result

11N/Aimport Common.GlobalAnnotations

11N/Aimport qualified Data.Map as Map

11N/Aimport qualified Data.Set as Set

11N/Aimport Common.Doc

11N/Aimport 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