{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} -- The Timber compiler -- -- Copyright 2008 Johan Nordlander -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions -- are met: -- -- 1. Redistributions of source code must retain the above copyright -- notice, this list of conditions and the following disclaimer. -- -- 2. Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- -- 3. Neither the names of the copyright holder and any identified -- contributors, nor the names of their affiliations, may be used to -- endorse or promote products derived from this software without -- specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS -- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR -- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, -- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN -- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -- POSSIBILITY OF SUCH DAMAGE. module Common (module Common, module Name, isDigit) where import PP import qualified List import qualified Maybe import Char import Name import Data.Binary import Debug.Trace fromJust = Maybe.fromJust listToMaybe = Maybe.listToMaybe fst3 (a,b,c) = a snd3 (a,b,c) = b thd3 (a,b,c) = c dom = map fst rng = map snd partition p xs = List.partition p xs nub xs = List.nub xs xs \\ ys = filter (`notElem` ys) xs xs `intersect` ys = xs `List.intersect` ys xs `union` ys = xs `List.union` ys disjoint xs ys = xs `intersect` ys == [] overlaps xs ys = not (disjoint xs ys) intersperse x xs = List.intersperse x xs duplicates xs = filter (`elem` dups) xs1 where xs1 = nub xs dups = foldl (flip List.delete) xs xs1 rotate n xs = let (xs1,xs2) = splitAt n xs in xs2++xs1 separate [] = ([],[]) separate (Left x : xs) = let (ls,rs) = separate xs in (x:ls,rs) separate (Right x : xs) = let (ls,rs) = separate xs in (ls,x:rs) showids vs = concat (intersperse ", " (map show vs)) fmapM f g xs = do ys <- mapM g xs return (f ys) mapFst f xs = [ (f a, b) | (a,b) <- xs ] mapSnd f xs = [ (a, f b) | (a,b) <- xs ] zipFilter (f:fs) (x:xs) | f = x : zipFilter fs xs | otherwise = zipFilter fs xs zipFilter _ _ = [] noDups mess vs | not (null dups) = errorIds mess dups | otherwise = vs where dups = duplicates vs uncurry3 f (x,y,z) = f x y z -- String manipulation ----------------------------------------------------- rmSuffix :: String -> String -> String rmSuffix suf = reverse . rmPrefix (reverse suf) . reverse rmPrefix :: String -> String -> String rmPrefix pre str | pre `List.isPrefixOf` str = drop (length pre) str | otherwise = error $ "rmPrefix: " ++ str ++ " is not a prefix of " ++ show pre rmDirs :: String -> String rmDirs = reverse . fst . span (/='/') . reverse dropPrefix [] s = (True, s) dropPrefix (x:xs) (y:ys) | x == y = dropPrefix xs ys dropPrefix xs ys = (False, ys) dropDigits xs = drop 0 xs where drop n (x:xs) | isDigit x = drop (10*n + ord x - ord '0') xs drop n xs = (n, xs) -- Error reporting --------------------------------------------------------- errorIds mess ns = error (unlines ((mess++":") : map pos ns)) where pos n = case loc n of Just (r,c) -> rJust 15 (show n) ++ " at line " ++ show r ++ ", column " ++ show c Nothing -> rJust 15 (show n) ++ modInfo n loc n = location (annot n) rJust w str = replicate (w-length str) ' ' ++ str modInfo (Name _ _ (Just m) a) = " defined in " ++ m modInfo _ = " (unknown position)" errorTree mess t = error (mess ++ pos ++ (if length (lines str) > 1 then "\n"++str++"\n" else str) ) where str = render (pr t) pos = " ("++ show (posInfo t) ++"): " internalError mess t = errorTree ("**** Internal compiler error ****\n" ++ mess) t internalError0 mess = error ("**** Internal compiler error ****\n" ++ mess) -- PosInfo --------------------------------------------------------- data PosInfo = Between {start :: (Int,Int), end :: (Int,Int)} | Unknown instance Show PosInfo where show (Between (l1,c1) (l2,c2)) = case l1==l2 of True -> case c1 == c2 of True -> "close to line "++show l1++", column "++show c1 False -> "close to line "++show l1++", columns "++show c1++" -- "++show c2 False -> "close to lines "++show l1++" -- "++show l2 show Unknown = "at unknown position" between (Between s1 e1) (Between s2 e2) = Between (min s1 s2) (max e1 e2) between b@(Between _ _) Unknown = b between Unknown b@(Between _ _) = b between Unknown Unknown = Unknown startPos (Between s _) = Just s startPos Unknown = Nothing class HasPos a where posInfo :: a -> PosInfo instance HasPos a => HasPos [a] where posInfo xs = foldr between Unknown (map posInfo xs) instance (HasPos a, HasPos b) => HasPos (a,b) where posInfo (a,b) = between (posInfo a) (posInfo b) instance HasPos a => HasPos (Maybe a) where posInfo Nothing = Unknown posInfo (Just a) = posInfo a instance HasPos Bool where posInfo _ = Unknown instance HasPos Name where posInfo n = case location (annot n) of Just (l,c) |l==0 && c==0 -> Unknown -- artificially introduced name |otherwise -> Between (l,c) (l,c+len n-1) Nothing -> Unknown where len(Name s _ _ _) = length s len(Prim p _) = length (strRep p) len(Tuple n _) = n+2 -- Literals ---------------------------------------------------------------- data Lit = LInt (Maybe (Int,Int)) Integer | LRat (Maybe (Int,Int)) Rational | LChr (Maybe (Int,Int)) Char | LStr (Maybe (Int,Int)) String -- deriving (Eq) instance Eq Lit where LInt _ m == LInt _ n = m == n LRat _ m == LRat _ n = m == n LChr _ m == LChr _ n = m == n LStr _ m == LStr _ n = m == n _ == _ = False instance Show Lit where show (LInt _ i) = "LInt " ++ show i show (LRat _ r) = "LRat " ++ show r show (LChr _ c) = "LChr " ++ show c show (LStr _ s) = "LStr " ++ show s instance Pr Lit where pr (LInt p i) = integer i pr (LRat _ r) = rational r pr (LChr _ c) = litChar c pr (LStr _ s) = litString s instance HasPos Lit where posInfo (LInt (Just (l,c)) i) = Between (l,c) (l,c+length(show i)-1) posInfo (LRat (Just (l,c)) r) = Between (l,c) (l,c) -- check length of rationals) posInfo (LChr (Just (l,c)) _) = Between (l,c) (l,c) posInfo (LStr (Just (l,c)) cs) = Between (l,c) (l,c+length cs+1) posInfo _ = Unknown lInt n = LInt Nothing (toInteger n) lRat r = LRat Nothing r lChr c = LChr Nothing c lStr s = LStr Nothing s -- Underlying monad ---------------------------------------------------------------------- newtype M s a = M ((Int,[s]) -> Either String ((Int,[s]), a)) instance Functor (M s) where fmap f x = x >>= (return . f) instance Monad (M s) where M m >>= f = M $ \k -> case m k of Right (k',a) -> m' k' where M m' = f a Left s -> Left s return a = M $ \k -> Right (k,a) fail s = M $ \k -> Left s handle (M m) f = M $ \k -> case m k of Right r -> Right r Left s -> m' k where M m' = f s expose (M m) = M $ \k -> case m k of Right (k',a) -> Right (k',Right a) Left s -> Right (k, Left s) unexpose (Right a) = return a unexpose (Left b) = fail b runM (M m) = case m (1,[]) of Right (_,x) -> x Left s -> error s newNum = M $ \(n,s) -> Right ((n+1,s), n) currentNum = M $ \(n,s) -> Right ((n,s), n) addToStore x = M $ \(n,s) -> Right ((n,x:s), ()) currentStore = M $ \(n,s) -> Right ((n,s), s) localStore (M m) = M $ \(n0,s0) -> case m (n0,[]) of Right ((n,s), x) -> Right ((n,s0), x) Left s -> Left s newNameMod m s = do n <- newNum return (Name s n m ann) where ann = if s `elem` explicitSyms then suppAnnot { explicit = True } else suppAnnot suppAnnot = genAnnot { suppressMod = True } newName s = newNameMod Nothing s newNames s n = mapM (const (newName s)) [1..n] newNamesPos s ps = mapM (newNamePos s) ps newNamePos s p = do n <- newName s return (n {annot = genAnnot {location = startPos(posInfo p)}}) renaming vs = mapM f vs where f v | tag v == 0 = do n <- newNum return (v, v { tag = n }) | otherwise = return (v, v) -- Merging renamings ------------------------------------------------------ -- Here we cannot use equality of names (Eq instance), since two unqualified -- imported names with the same string will have non-zero tags and hence not be compared -- for str equality. -- remove pairs from rn2 that are shadowed by rn1; return also shadowed names deleteRenamings [] rn2 = (rn2,[]) deleteRenamings ((n,_):rn1) rn2 | not(isQualified n) = (rn',if b then n:ns else ns) | otherwise = (rn,ns) where (rn,ns) = deleteRenamings rn1 rn2 (b,rn') = deleteName n rn deleteName _ [] = (False,[]) deleteName n ((Name s t Nothing a,_):rn) | str n == s = (True,rn) deleteName n (p:rn) = let (b,rn') = deleteName n rn in (b,p:rn') -- for merging renaming for locally bound names with ditto for imported names; -- removes unqualified form of imported name mergeRenamings1 rn1 rn2 = rn1 ++ rn2' where (rn2',_) = deleteRenamings rn1 rn2 -- for merging renamings from two imported modules; -- removes both occurrences when two unqualified names clash mergeRenamings2 rn1 rn2 = case ns' of [] -> rn1' ++ rn2' _ -> tr' ("Warning: clash of imported name(s): "++showids ns' ++ "(hence not in scope)\n") (rn1' ++ rn2') where (rn2',ns) = deleteRenamings rn1 rn2 rn1' = deleteNames ns rn1 ns' = filter (not . isGenerated) ns deleteNames [] rn = rn deleteNames (n:ns) rn = deleteNames ns (snd (deleteName n rn)) -- Assertions ----------------------------------------------------------------------- assert e msg ns | e = return () | otherwise = errorIds msg ns assert1 e msg ts | e = return () | otherwise = errorTree msg ts -- Poor man's exception datatype ------------------------------------------------------ encodeError msg ids = msg ++ ": " ++ concat (intersperse " " (map packName ids)) decodeError str | msg `elem` encodedMsgs = Just (msg, map unpackName (words rest)) | otherwise = Nothing where (msg,_:rest) = span (/=':') str encodedMsgs = [circularSubMsg, ambigInstMsg, ambigSubMsg] circularSubMsg = "Circular subtyping" ambigInstMsg = "Ambiguous instances" ambigSubMsg = "Ambiguous subtyping" assert0 e msg | e = return () | otherwise = fail msg -- Tracing ----------------------------------------------------------------------------- tr m = trace (m++"\n") (return ()) tr' m e = trace ("\n"++m++"\n") e trNum str = do n <- currentNum tr ("At "++show n++": "++str) -- Free variables ----------------------------------------------------------------------- class Ids a where idents :: a -> [Name] instance Ids a => Ids [a] where idents xs = concatMap idents xs instance Ids a => Ids (Name,a) where idents (v,a) = idents a tycons x = filter isCon (idents x) tyvars x = filter isVar (idents x) evars x = filter isVar (idents x) svars x = filter isState (idents x) vclose vss vs | null vss2 = nub vs | otherwise = vclose vss1 (concat vss2 ++ vs) where (vss1,vss2) = partition (null . intersect vs) vss -- Bound variables ----------------------------------------------------------------------- class BVars a where bvars :: a -> [Name] bvars _ = [] -- Mappings ----------------------------------------------------------------------------- infixr 4 @@ type Map a b = [(a,b)] lookup' assoc x = case lookup x assoc of Just e -> e Nothing -> internalError "lookup': did not find" x lookup'' s assoc x = case lookup x assoc of Just e -> e Nothing -> internalError ("lookup' (" ++ s ++ "): did not find") x inv assoc = map (\(a,b) -> (b,a)) assoc delete k [] = [] delete k (x:xs) | fst x == k = xs | otherwise = x : delete k xs delete' ks xs = foldr delete xs ks insert k x [] = [(k,x)] insert k x ((k',x'):assoc) | k == k' = (k,x) : assoc | otherwise = (k',x') : insert k x assoc update k f [] = error "Internal: Common.update" update k f ((k',x):assoc) | k == k' = (k, f x) : assoc | otherwise = (k',x) : update k f assoc search p [] = Nothing search p (a:assoc) | p a = Just a | otherwise = search p assoc insertBefore kx ks [] = [kx] insertBefore kx ks ((k,x'):assoc) | k `elem` ks = kx:(k,x'):assoc | otherwise = (k,x') : insertBefore kx ks assoc (@@) :: Subst b a b => Map a b -> Map a b -> Map a b s1 @@ s2 = [(u,subst s1 t) | (u,t) <- s2] ++ s1 merge :: (Eq a, Eq b) => Map a b -> Map a b -> Maybe (Map a b) merge [] s' = Just s' merge ((v,t):s) s' = case lookup v s' of Nothing -> merge s ((v,t):s') Just t' | t==t' -> merge s s' _ -> Nothing nullSubst = [] a +-> b = [(a,b)] restrict s vs = filter ((`elem` vs) . fst) s prune s vs = filter ((`notElem` vs) . fst) s class Subst a i e where subst :: Map i e -> a -> a substVars s xs = map (substVar s) xs substVar s x = case lookup x s of Just x' -> x' Nothing -> x instance Subst a i e => Subst [a] i e where subst [] xs = xs subst s xs = map (subst s) xs instance Subst a i e => Subst (Name,a) i e where subst s (v,a) = (v, subst s a) instance Subst a i e => Subst (Maybe a) i e where subst s Nothing = Nothing subst s (Just a) = Just (subst s a) newEnv x ts = do vs <- mapM (const (newName x)) ts return (vs `zip` ts) newEnvPos x ts e = do vs <- mapM (const (newNamePos x e)) ts return (vs `zip` ts) -- Kinds --------------------------------------------------------------------------------- data Kind = Star | KFun Kind Kind | KWild | KVar Int deriving (Eq,Show) instance HasPos Kind where posInfo _ = Unknown newtype TVar = TV (Int,Kind) type KEnv = Map Name Kind instance Eq TVar where TV (n,k) == TV (n',k') = n == n' instance Show TVar where show (TV (n,k)) = show n instance Pr TVar where pr (TV (n,k)) = pr n newTV k = do n <- newNum return (TV (n,k)) newKVar = do n <- newNum return (KVar n) tvKind (TV (n,k)) = k kvars Star = [] kvars (KVar n) = [n] kvars (KFun k1 k2) = kvars k1 ++ kvars k2 kArgs (KFun k k') = k : kArgs k' kArgs k = [] kFlat k = (kArgs k, kRes k) kRes (KFun k k') = kRes k' kRes k = k instance Subst Kind Int Kind where subst s Star = Star subst s k@(KVar n) = case lookup n s of Just k' -> k' Nothing -> k subst s (KFun k1 k2) = KFun (subst s k1) (subst s k2) instance Subst (Kind,Kind) Int Kind where subst s (a,b) = (subst s a, subst s b) instance Pr (Name,Kind) where pr (n,k) = prId n <+> text "::" <+> pr k instance Pr Kind where prn 0 (KFun k1 k2) = prn 1 k1 <+> text "->" <+> prn 0 k2 prn 0 k = prn 1 k prn 1 Star = text "*" prn 1 (KVar n) = text ('_':show n) prn 1 KWild = text "_" prn 1 k = parens (prn 0 k) class TVars a where tvars :: a -> [TVar] instance TVars a => TVars [a] where tvars xs = concatMap tvars xs instance TVars a => TVars (Name,a) where tvars (v,a) = tvars a -- Defaults ------------------------------------------ data Default a = Default Bool Name Name -- First arg is True if declaration is in public part | Derive Name a deriving (Eq, Show) instance Pr a => Pr(Default a) where pr (Default _ a b) = pr a <+> text "<" <+> pr b pr (Derive v t) = pr v <+> text "::" <+> pr t instance HasPos a => HasPos (Default a) where posInfo (Default _ a b) = between (posInfo a) (posInfo b) posInfo (Derive v t) = between (posInfo v) (posInfo t) -- Binary -------------------------------------------- instance Binary Lit where put (LInt _ a) = putWord8 0 >> put a put (LRat _ a) = putWord8 1 >> put a put (LChr _ a) = putWord8 2 >> put a put (LStr _ a) = putWord8 3 >> put a get = do tag_ <- getWord8 case tag_ of 0 -> get >>= \a -> return (lInt (a::Integer)) 1 -> get >>= \a -> return (lRat a) 2 -> get >>= \a -> return (lChr a) 3 -> get >>= \a -> return (lStr a) _ -> fail "no parse" instance Binary Kind where put Star = putWord8 0 put (KFun a b) = putWord8 1 >> put a >> put b put KWild = putWord8 2 put (KVar a) = putWord8 3 >> put a get = do tag_ <- getWord8 case tag_ of 0 -> return Star 1 -> get >>= \a -> get >>= \b -> return (KFun a b) 2 -> return KWild 3 -> get >>= \a -> return (KVar a) _ -> fail "no parse" instance Binary TVar where put (TV a) = put a get = get >>= \a -> return (TV a) instance Binary a => Binary (Default a) where put (Default a b c) = putWord8 0 >> put a >> put b >> put c put (Derive a b) = putWord8 1 >> put a >> put b get = do tag_ <- getWord8 case tag_ of 0 -> get >>= \a -> get >>= \b -> get >>= \c -> return (Default a b c) 1 -> get >>= \a -> get >>= \b -> return (Derive a b)