AsToLe.hs revision f0742398d4587242b1a115de113cd17f63dcb6d0
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu Authors: Christian Maeder
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiumodule AsToLe where
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiuimport AS_Annotation
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiuimport ClassDecl
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiuimport MonadState
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiuimport FiniteMap
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiuimport ParseTerm(isSimpleId)
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiuimport MixfixParser(getTokenList, expandPos)
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiuimport ParsecPos
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiuimport ParsecError
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu----------------------------------------------------------------------------
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu-----------------------------------------------------------------------------
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaBasicSpec :: BasicSpec -> State Env ()
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaBasicSpec (BasicSpec l) = mapM_ anaAnnotedBasicItem l
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaAnnotedBasicItem :: Annoted BasicItem -> State Env ()
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaAnnotedBasicItem i = anaBasicItem $ item i
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaBasicItem :: BasicItem -> State Env ()
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaBasicItem (SigItems i) = anaSigItems i
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaBasicItem (ClassItems inst l _) = mapM_ (anaAnnotedClassItem inst) l
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaBasicItem (GenVarItems l _) = mapM_ anaGenVarDecl l
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaSigItems :: SigItems -> State Env ()
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaSigItems(TypeItems inst l _) = mapM_ (anaAnnotedTypeItem inst) l
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu----------------------------------------------------------------------------
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu-----------------------------------------------------------------------------
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaGenVarDecl :: GenVarDecl -> State Env ()
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaGenVarDecl(GenVarDecl v) = optAnaVarDecl v
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaGenVarDecl(GenTypeVarDecl t) = anaTypeVarDecl t
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuconvertTypeToClass :: ClassMap -> Type -> Result Class
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuconvertTypeToClass cMap (TypeToken t) =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu if tokStr t == "Type" then Result [] (Just $ universe) else
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu let ci = simpleIdToId t
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu ds = anaClassId cMap ci
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu in if null ds then
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu Result [] (Just $ Intersection [ci] [])
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu else Result ds Nothing
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuconvertTypeToClass cMap (BracketType Parens ts ps) =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu let is = map (convertTypeToClass cMap) ts
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu mis = map maybeResult is
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu ds = concatMap diags is
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu in if all isJust mis then Result ds
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu (Just $ Intersection (concatMap (iclass . fromJust) mis) ps)
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu else Result ds Nothing
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuconvertTypeToClass _ _ = Result [] Nothing
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuoptAnaVarDecl, anaVarDecl :: VarDecl -> State Env ()
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuoptAnaVarDecl vd@(VarDecl v t _ _) =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu if isSimpleId v then
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu do cMap <- getClassMap
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu let Result _ mc = convertTypeToClass cMap t
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu Just c -> addTypeKind v (Kind [] c [])
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu Nothing -> anaVarDecl vd
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu else anaVarDecl vd
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaVarDecl(VarDecl v oldT _ p) =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu do t <- anaType oldT
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu as <- getAssumps
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu let l = lookupWithDefaultFM as [] v
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu ts = SimpleTypeScheme t in
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu if ts `elem` l then
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu ("repeated variable '"
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu ++ showId v "'") p ]
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu else putAssumps $ addToFM as v (ts:l)
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaTypeVarDecl :: TypeVarDecl -> State Env ()
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaTypeVarDecl(TypeVarDecl t k _ _) =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu do nk <- anaKind k
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu addTypeKind t k
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu-- ------------------------------------------------------------------------------ ClassItem
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu-- ----------------------------------------------------------------------------
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaAnnotedClassItem :: Instance -> Annoted ClassItem -> State Env ()
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaAnnotedClassItem _ aci =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu let ClassItem d l _ = item aci in
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu do anaClassDecls d
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu mapM_ anaAnnotedBasicItem l
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu-- ----------------------------------------------------------------------------
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu-- ----------------------------------------------------------------------------
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaAnnotedTypeItem :: Instance -> Annoted TypeItem -> State Env ()
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaAnnotedTypeItem inst i = anaTypeItem inst $ item i
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaTypeItem :: Instance -> TypeItem -> State Env ()
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaTypeItem inst (TypeDecl pats kind _) =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu do k <- anaKind kind
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu mapM_ (anaTypePattern inst k) pats
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaTypePattern :: Instance -> Kind -> TypePattern -> State Env ()
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu-- type args not yet considered for kind construction
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaTypePattern _ kind t =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu let Result ds mi = convertTypePattern t
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu in if typePatternArgs t == 0 ||
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu typePatternArgs t == kindArity kind then
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu Just ti -> addTypeKind ti kind
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu Nothing -> appendDiags ds
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu else appendDiags [Diag Error "non-matching kind arity"
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu $ posOfTypePattern t]
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuconvertTypePattern, makeMixTypeId :: TypePattern -> Result Id
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuconvertTypePattern (TypePattern t _ _) = return t
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuconvertTypePattern(TypePatternToken t) =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu if isPlace t then fatal_error ("illegal type '__'") (tokPos t)
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu else return $ (simpleIdToId t)
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuconvertTypePattern t =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu if hasPlaces t && hasTypeArgs t then
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu fatal_error ( "illegal mix of '__' and '(...)'" )
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu (posOfTypePattern t)
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu else makeMixTypeId t
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiutypePatternToTokens :: TypePattern -> [Token]
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiutypePatternToTokens (TypePattern ti _ _) = getTokenList True ti
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiutypePatternToTokens (TypePatternToken t) = [t]
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiutypePatternToTokens (MixfixTypePattern ts) = concatMap typePatternToTokens ts
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiutypePatternToTokens (BracketTypePattern pk ts ps) =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu let tts = map typePatternToTokens ts
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu expand = expandPos (:[]) in
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu Parens -> if length tts == 1 &&
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu length (head tts) == 1 then head tts
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu else concat $ expand "(" ")" tts ps
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu Squares -> concat $ expand "[" "]" tts ps
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu Braces -> concat $ expand "{" "}" tts ps
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiutypePatternToTokens (TypePatternArgs as) =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu map ( \ (TypeArg v _ _ _) -> Token "__" (tokPos v)) as
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu-- compound Ids not supported yet
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiugetToken :: GenParser Token st Token
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiugetToken = token tokStr (( \ (l, c) -> newPos "" l c) . tokPos) Just
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuparseTypePatternId :: GenParser Token st Id
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuparseTypePatternId =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu do ts <- many1 getToken
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu return $ Id ts [] []
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiumakeMixTypeId t =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu case parse parseTypePatternId "" (typePatternToTokens t) of
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu Left err -> fatal_error (showErrorMessages "or" "unknown parse error"
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu "expecting" "unexpected" "end of input"
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu (errorMessages err))
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu (let p = errorPos err in (sourceLine p, sourceColumn p))
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu Right x -> return x
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiutypePatternArgs :: TypePattern -> Int
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiutypePatternArgs (TypePattern _ as _) = length as
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiutypePatternArgs (TypePatternToken t) = if isPlace t then 1 else 0
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiutypePatternArgs (MixfixTypePattern ts) = sum (map typePatternArgs ts)
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiutypePatternArgs (BracketTypePattern _ ts _) = sum (map typePatternArgs ts)
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiutypePatternArgs (TypePatternArgs as) = length as
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuhasPlaces, hasTypeArgs :: TypePattern -> Bool
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuhasPlaces (TypePattern _ _ _) = False
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuhasPlaces (TypePatternToken t) = isPlace t
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuhasPlaces (MixfixTypePattern ts) = any hasPlaces ts
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuhasPlaces (BracketTypePattern Parens _ _) = False
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuhasPlaces (BracketTypePattern _ ts _) = any hasPlaces ts
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuhasPlaces (TypePatternArgs _) = False
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuhasTypeArgs (TypePattern _ _ _) = True
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuhasTypeArgs (TypePatternToken _) = False
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuhasTypeArgs (MixfixTypePattern ts) = any hasTypeArgs ts
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuhasTypeArgs (BracketTypePattern Parens _ _) = True
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuhasTypeArgs (BracketTypePattern _ ts _) = any hasTypeArgs ts
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuhasTypeArgs (TypePatternArgs _) = True
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu-- ----------------------------------------------------------------------------
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu-- ----------------------------------------------------------------------------
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuaddTypeKind :: Id -> Kind -> State Env ()
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuaddTypeKind t k =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu do tk <- getTypeKinds
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu case lookupFM tk t of
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu Just ks -> do appendDiags [Diag Warning
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu ("shadowing type '"
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu ++ showId t "'")
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu putTypeKinds $ addToFM tk t (k:ks)
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu _ -> putTypeKinds $ addToFM tk t [k]
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu-- add instances later on
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu let ce = classEnv e
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu mc = lookupFM ce ci
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu Nothing -> do appendDiags [Error ("undeclared class '"
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu ++ tokStr c ++ "'")
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu Just info -> do put $ e { classEnv =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu addToFM ce ci info
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu [] :=> (ci `IsIn` TCon (Tycon t k))
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu : instances info } }