timberc-1.0.3: src/Common.hs
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveDataTypeable #-}
-- The Timber compiler <timber-lang.org>
--
-- Copyright 2008-2009 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 Control.Exception
import Char
import Config
import Name
import Data.Typeable
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 = internalError0 $ "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 = compileError (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 = compileError (errorMsg mess t)
compileError mess = throw (CompileError mess)
errorMsg mess t = 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 = internalError0 (errorMsg mess t)
internalError0 mess = throw (Panic 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 -> compileError 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 [] = internalError0 "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)
deriving (Typeable)
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)