AsToLe.hs revision 024621f43239cfe9629e35d35a8669fad7acbba2
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu Authors: Christian Maeder
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiumodule AsToLe where
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiuimport AS_Annotation
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiuimport MonadState
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiuimport FiniteMap
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu----------------------------------------------------------------------------
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu-- FiniteMap stuff
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu-----------------------------------------------------------------------------
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiulookUp :: (Ord a, MonadPlus m) => FiniteMap a (m b) -> a -> (m b)
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiulookUp ce = lookupWithDefaultFM ce mzero
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiushowMap :: Ord a => (a -> ShowS) -> (b -> ShowS) -> FiniteMap a b -> ShowS
a604cbad8e2202147b5c6bb9f2e06ae61162d654Felix Gabriel ManceshowMap showA showB m =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu showSepList (showChar '\n') (\ (a, b) -> showA a . showString " -> " .
be2439588008221e691321fdf4f75432cfb72878Felix Gabriel Mance indent 2 (showB b))
b84c87f199dc287d235d7dad6ea344f6912ef531Christian Maeder-----------------------------------------------------------------------------
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiuindent :: Int -> ShowS -> ShowS
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiuindent i s = showString $ concat $
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu intersperse ('\n' : replicate i ' ') (lines $ s "")
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu-----------------------------------------------------------------------------
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiutype ClassEnv = FiniteMap ClassName Le.ClassItem
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu-- transitiv super classes
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu-- PRE: all superclasses and defns must be defined in ClassEnv
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu-- and there must be no cycle!
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuallSuperClasses :: ClassEnv -> ClassName -> [ClassName]
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuallSuperClasses ce ci =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu case lookupFM ce ci of
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu Just info -> nub $
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu ci: concatMap (allSuperClasses ce) (iclass $
b84c87f199dc287d235d7dad6ea344f6912ef531Christian Maeder classDefn info)
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu ++ concatMap (allSuperClasses ce) (superClasses info)
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu Nothing -> error "allSuperClasses"
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiudefCEntry ce cid sups defn = addToFM ce cid
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu (newClassItem cid) { superClasses = sups
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu , classDefn = defn }
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu-----------------------------------------------------------------------------
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu-----------------------------------------------------------------------------
be00381168b3f10192afabbba136fb06d3a9f358Christian Maedertype Assumps = FiniteMap Id [TypeScheme]
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiutype TypeKinds = FiniteMap TypeName [Kind]
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu-----------------------------------------------------------------------------
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu-----------------------------------------------------------------------------
d0f58d27c2536eba454d8f77de8617bc6a2c99cdFelix Gabriel Mancedata Env = Env { classEnv :: ClassEnv
d0f58d27c2536eba454d8f77de8617bc6a2c99cdFelix Gabriel Mance , typeKinds :: TypeKinds
d0f58d27c2536eba454d8f77de8617bc6a2c99cdFelix Gabriel Mance , assumps :: Assumps
d0f58d27c2536eba454d8f77de8617bc6a2c99cdFelix Gabriel Mance , envDiags :: [Diagnosis]
d0f58d27c2536eba454d8f77de8617bc6a2c99cdFelix Gabriel Mance } deriving Show
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuinitialEnv = Env emptyFM emptyFM emptyFM []
60f30f0eeeacdfc1e0dfe39664373ddf5a0675adFelix Gabriel ManceappendDiags ds =
60f30f0eeeacdfc1e0dfe39664373ddf5a0675adFelix Gabriel Mance if null ds then return () else
0dd6e7830de0887c9a12356447975a826b3b3db2Christian Maeder put $ e {envDiags = ds ++ envDiags e}
60f30f0eeeacdfc1e0dfe39664373ddf5a0675adFelix Gabriel MancegetClassEnv :: State Env ClassEnv
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiugetClassEnv = gets classEnv
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiugetTypeKinds :: State Env TypeKinds
60f30f0eeeacdfc1e0dfe39664373ddf5a0675adFelix Gabriel MancegetTypeKinds = gets typeKinds
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuputTypeKinds tk = do { e <- get; put e { typeKinds = tk } }
9475501a6acf48434052d9e6f4a05ed6681eaaabFrancisc Nicolae BungiuputClassEnv ce = do { e <- get; put e { classEnv = ce } }
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu----------------------------------------------------------------------------
60f30f0eeeacdfc1e0dfe39664373ddf5a0675adFelix Gabriel Mance-----------------------------------------------------------------------------
0dd6e7830de0887c9a12356447975a826b3b3db2Christian MaederanaBasicSpec (BasicSpec l) = mapM_ anaAnnotedBasicItem l
60f30f0eeeacdfc1e0dfe39664373ddf5a0675adFelix Gabriel ManceanaAnnotedBasicItem i = anaBasicItem $ item i
0dd6e7830de0887c9a12356447975a826b3b3db2Christian MaederanaBasicItem (SigItems i) = anaSigItems i
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaBasicItem (ClassItems inst l _) = mapM_ (anaAnnotedClassItem inst) l
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaBasicItem (GenVarItems l _) = mapM_ anaGenVarDecl l
60f30f0eeeacdfc1e0dfe39664373ddf5a0675adFelix Gabriel ManceanaSigItems(TypeItems inst l _) = mapM_ (anaAnnotedTypeItem inst) l
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaGenVarDecl(GenVarDecl v) = optAnaVarDecl v
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaGenVarDecl(GenTypeVarDecl t) = anaTypeDecl t
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuoptAnaVarDecl = error "nyi"
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuoptAnaVarDecl(VarDecl v t _ _) =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu let mc = TypeToClass t in
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu if isSimpleId v && isJust mc then
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaTypeDecl= error "nyi"
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaAnnotedClassItem inst aci =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu let As.ClassItem d l _ = item aci in
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu do anaClassDecls d
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu mapM_ anaAnnotedBasicItem l
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaClassDecls (ClassDecl cls _) = mapM_ (anaClassDecl []) cls
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaClassDecls (SubclassDecl cls supcl _) =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu do Intersection scls _ <- anaSuperClass supcl
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu mapM_ (anaClassDecl scls) cls
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaClassDecls (ClassDefn ci syncl ps) =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu do scls@(Intersection icls _) <- anaClassAppl syncl
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu ce <- getClassEnv
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu case lookupFM ce ci of
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu Nothing -> putClassEnv $ defCEntry ce ci [] scls
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu do appendDiags [Warning ("redeclared class '"
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu ++ tokStr ci ++ "'")
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu let supers = zip (map (allSuperClasses ce) icls) icls
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu (cycles, nocycles) = partition ((ci `elem`) . fst) supers
0dd6e7830de0887c9a12356447975a826b3b3db2Christian Maeder Intersection iClasses qs = classDefn info in
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu do if not $ null cycles then
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu appendDiags [Error
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu ("cyclic class definition via '"
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu ++ showClassList (map snd cycles) "'")
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu $ tokPos (snd $ head cycles)]
06acd8a23b2f06e7b2373d53f738cf56c7f03223Francisc Nicolae Bungiu putClassEnv $ addToFM ce ci
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu info { classDefn = Intersection (
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu nub $ map snd nocycles
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu ++ iClasses) (ps ++ qs) }
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaClassName b ci =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu do ce <- getClassEnv
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu if isJust $ lookupFM ce ci then return $ return [ci]
be00381168b3f10192afabbba136fb06d3a9f358Christian Maeder else if b then
0dd6e7830de0887c9a12356447975a826b3b3db2Christian Maeder do putClassEnv $ defCEntry ce ci [] (Intersection [] [])
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu return $ return [ci]
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu return $ non_fatal_error []
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu ("undeclared class '" ++ tokStr ci ++ "'")
b84c87f199dc287d235d7dad6ea344f6912ef531Christian MaederanaClass b c@(As.Intersection cs ps) =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu if null cs && not (null ps)
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu then return $ warning c "redundant universe class" (head ps)
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu do cs <- mapM (anaClassName False) cs
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu return $ Result (concatMap diags cs)
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu (Just $ Intersection
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu (nub $ concatMap (fromJust . maybeResult) cs) ps)
624f8c31bd8d6746b93f4b5966aa6fc7680fefc5Felix Gabriel ManceanaSuperClass c =
624f8c31bd8d6746b93f4b5966aa6fc7680fefc5Felix Gabriel Mance do Result ds (Just ca) <- anaClass True c
624f8c31bd8d6746b93f4b5966aa6fc7680fefc5Felix Gabriel Mance appendDiags ds
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaClassAppl c =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu do Result ds (Just ca) <- anaClass False c
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaClassDecl scls ci =
b84c87f199dc287d235d7dad6ea344f6912ef531Christian Maeder if tokStr ci == "Type" then
624f8c31bd8d6746b93f4b5966aa6fc7680fefc5Felix Gabriel Mance appendDiags [Error "illegal universe class declaration" (tokPos ci)]
624f8c31bd8d6746b93f4b5966aa6fc7680fefc5Felix Gabriel Mance do ce <- getClassEnv
624f8c31bd8d6746b93f4b5966aa6fc7680fefc5Felix Gabriel Mance case lookupFM ce ci of
624f8c31bd8d6746b93f4b5966aa6fc7680fefc5Felix Gabriel Mance Nothing -> putClassEnv $ defCEntry ce ci
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu scls (Intersection [] [])
86f318f607745d1f40cbf87048a13ac1c65100e6Felix Gabriel Mance do appendDiags [Warning ("redeclared class '"
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu ++ tokStr ci ++ "'")
86f318f607745d1f40cbf87048a13ac1c65100e6Felix Gabriel Mance if null scls then return ()
be2439588008221e691321fdf4f75432cfb72878Felix Gabriel Mance else let supers = zip (map (allSuperClasses ce) scls)
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu (cycles, nocycles) =
d0f58d27c2536eba454d8f77de8617bc6a2c99cdFelix Gabriel Mance partition ((ci `elem`) . fst) supers
d0f58d27c2536eba454d8f77de8617bc6a2c99cdFelix Gabriel Mance sups = superClasses info in
d0f58d27c2536eba454d8f77de8617bc6a2c99cdFelix Gabriel Mance do if not $ null cycles then
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu ("cyclic class relation via '"
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu ++ showClassList (map snd cycles) "'")
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu $ tokPos (snd $ head cycles)]
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu putClassEnv $ addToFM ce ci
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu (info { superClasses =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu nub $ map snd nocycles ++ sups })
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu let ds = filter (`elem` sups) scls in
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu if null $ ds then return ()
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu else appendDiags [Warning
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu ("repeated superclass '"
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu ++ showClassList ds "'")
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu $ tokPos (head ds)]
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaAnnotedTypeItem inst i = anaTypeItem inst $ item i
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaTypeItem inst (TypeDecl pats kind _) =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu mapM_ (anaTypePattern inst kind) pats
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaTypePattern inst kind (TypePatternToken t) =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu let ty = simpleIdToId t
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu in do k <- anaKind kind ty
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu addTypeKind ty k
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae BungiuanaKind (Kind [] c p) t =
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu do ca <- anaClassAppl c
ee93ea764a2b8189253e912c8447f9419033f6d4Francisc Nicolae Bungiu return $ Kind [] ca p
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 ++ "'")
a6526952d69bccd048c954eb920493a6a83e78faFelix Gabriel Mance 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 } }
86f318f607745d1f40cbf87048a13ac1c65100e6Felix Gabriel ManceanaExtClass (ExtClass c v p) =
2713ec15465bd1e643f6310d7048b5a30ad55c83Christian Maeder do ca <- anaClassAppl c
86f318f607745d1f40cbf87048a13ac1c65100e6Felix Gabriel Mance return $ ExtClass ca v p
2713ec15465bd1e643f6310d7048b5a30ad55c83Christian MaederanaProdClass (ProdClass l p) =
86f318f607745d1f40cbf87048a13ac1c65100e6Felix Gabriel Mance do cs <- mapM anaExtClass l
f20c085644aa49702488405bc2d4245cf0e5a713Felix Gabriel Mance return $ ProdClass cs p
86f318f607745d1f40cbf87048a13ac1c65100e6Felix Gabriel ManceaddTypeKind t k =
f20c085644aa49702488405bc2d4245cf0e5a713Felix Gabriel Mance do tk <- getTypeKinds
86f318f607745d1f40cbf87048a13ac1c65100e6Felix Gabriel Mance let l = lookUp tk t in
86f318f607745d1f40cbf87048a13ac1c65100e6Felix Gabriel Mance if k `elem` l then
86f318f607745d1f40cbf87048a13ac1c65100e6Felix Gabriel Mance appendDiags [Warning ("redeclared type '"
2713ec15465bd1e643f6310d7048b5a30ad55c83Christian Maeder ++ showId t "'")
86f318f607745d1f40cbf87048a13ac1c65100e6Felix Gabriel Mance else putTypeKinds $ addToFM tk t (k:l)