timberc-1.0.1: src/Common.hs
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
-- The Timber compiler <timber-lang.org>
--
-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>
-- 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)