summaryrefslogtreecommitdiff
path: root/src/compiler/GF/Compile
diff options
context:
space:
mode:
authorJohn J. Camilleri <john@digitalgrammars.com>2021-07-07 09:40:41 +0200
committerJohn J. Camilleri <john@digitalgrammars.com>2021-07-07 09:40:41 +0200
commitf2e52d6f2c2bc90febceebdea0268b40ea37476c (patch)
tree710619761319d65c5d997ec008f57f9253eae5dd /src/compiler/GF/Compile
parenta2b23d5897b4c04b50cd222ce8f215e45a3b6e40 (diff)
Replace tabs for whitespace in source code
Diffstat (limited to 'src/compiler/GF/Compile')
-rw-r--r--src/compiler/GF/Compile/CFGtoPGF.hs12
-rw-r--r--src/compiler/GF/Compile/CheckGrammar.hs4
-rw-r--r--src/compiler/GF/Compile/Rename.hs26
-rw-r--r--src/compiler/GF/Compile/TypeCheck/Abstract.hs16
-rw-r--r--src/compiler/GF/Compile/TypeCheck/Concrete.hs1
-rw-r--r--src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs16
-rw-r--r--src/compiler/GF/Compile/TypeCheck/TC.hs88
-rw-r--r--src/compiler/GF/Compile/Update.hs66
8 files changed, 114 insertions, 115 deletions
diff --git a/src/compiler/GF/Compile/CFGtoPGF.hs b/src/compiler/GF/Compile/CFGtoPGF.hs
index f9ab8afcf..59448ce97 100644
--- a/src/compiler/GF/Compile/CFGtoPGF.hs
+++ b/src/compiler/GF/Compile/CFGtoPGF.hs
@@ -18,7 +18,7 @@ import Data.List
--------------------------
cf2pgf :: FilePath -> ParamCFG -> PGF
-cf2pgf fpath cf =
+cf2pgf fpath cf =
let pgf = PGF Map.empty aname (cf2abstr cf) (Map.singleton cname (cf2concr cf))
in updateProductionIndices pgf
where
@@ -33,7 +33,7 @@ cf2abstr cfg = Abstr aflags afuns acats
acats = Map.fromList [(cat, ([], [(0,mkRuleName rule) | rule <- rules], 0))
| (cat,rules) <- (Map.toList . Map.fromListWith (++))
- [(cat2id cat, catRules cfg cat) |
+ [(cat2id cat, catRules cfg cat) |
cat <- allCats' cfg]]
afuns = Map.fromList [(mkRuleName rule, (cftype [cat2id c | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)), 0, Nothing, 0))
| rule <- allRules cfg]
@@ -52,7 +52,7 @@ cf2concr cfg = Concr Map.empty Map.empty
cats = allCats' cfg
rules = allRules cfg
- sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] :
+ sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] :
map mkSequence rules)
sequences = listArray (0,Set.size sequences0-1) (Set.toList sequences0)
@@ -102,7 +102,7 @@ cf2concr cfg = Concr Map.empty Map.empty
mkLinDefRef (cat,_) =
(cat2fid cat 0,[0])
-
+
addProd prods (fid,prod) =
case IntMap.lookup fid prods of
Just set -> IntMap.insert fid (Set.insert prod set) prods
@@ -130,5 +130,5 @@ cf2concr cfg = Concr Map.empty Map.empty
mkRuleName rule =
case ruleName rule of
- CFObj n _ -> n
- _ -> wildCId
+ CFObj n _ -> n
+ _ -> wildCId
diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs
index 71bce96c4..7f053f85c 100644
--- a/src/compiler/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/GF/Compile/CheckGrammar.hs
@@ -175,7 +175,7 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
checkTyp gr typ
case md of
Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $
- checkDef gr (m,c) typ eq) eqs
+ checkDef gr (m,c) typ eq) eqs
Nothing -> return ()
return (AbsFun (Just (L loc typ)) ma md moper)
@@ -316,7 +316,7 @@ linTypeOfType cnc m typ = do
mkLinArg (i,(n,mc@(m,cat))) = do
val <- lookLin mc
let vars = mkRecType varLabel $ replicate n typeStr
- symb = argIdent n cat i
+ symb = argIdent n cat i
rec <- if n==0 then return val else
errIn (render ("extending" $$
nest 2 vars $$
diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs
index c7ea56b45..41b2cdc67 100644
--- a/src/compiler/GF/Compile/Rename.hs
+++ b/src/compiler/GF/Compile/Rename.hs
@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/05/30 18:39:44 $
+-- > CVS $Date: 2005/05/30 18:39:44 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.19 $
--
@@ -23,9 +23,9 @@
-----------------------------------------------------------------------------
module GF.Compile.Rename (
- renameSourceTerm,
- renameModule
- ) where
+ renameSourceTerm,
+ renameModule
+ ) where
import GF.Infra.Ident
import GF.Infra.CheckM
@@ -68,7 +68,7 @@ renameIdentTerm env = accumulateError (renameIdentTerm' env)
-- Fails immediately on error, makes it possible to try other possibilities
renameIdentTerm' :: Status -> Term -> Check Term
-renameIdentTerm' env@(act,imps) t0 =
+renameIdentTerm' env@(act,imps) t0 =
case t0 of
Vr c -> ident predefAbs c
Cn c -> ident (\_ s -> checkError s) c
@@ -85,8 +85,8 @@ renameIdentTerm' env@(act,imps) t0 =
_ -> return t0
where
opens = [st | (OSimple _,st) <- imps]
- qualifs = [(m, st) | (OQualif m _, st) <- imps] ++
- [(m, st) | (OQualif _ m, st) <- imps] ++
+ qualifs = [(m, st) | (OQualif m _, st) <- imps] ++
+ [(m, st) | (OQualif _ m, st) <- imps] ++
[(m, st) | (OSimple m, st) <- imps] -- qualif is always possible
-- this facility is mainly for BWC with GF1: you need not import PredefAbs
@@ -94,7 +94,7 @@ renameIdentTerm' env@(act,imps) t0 =
| isPredefCat c = return (Q (cPredefAbs,c))
| otherwise = checkError s
- ident alt c =
+ ident alt c =
case Map.lookup c act of
Just f -> return (f c)
_ -> case mapMaybe (Map.lookup c) opens of
@@ -157,7 +157,7 @@ modInfo2status (o,mo) = (o,tree2status o (jments mo))
self2status :: ModuleName -> ModuleInfo -> StatusMap
self2status c m = Map.mapWithKey (info2status (Just c)) (jments m)
-
+
renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info
renameInfo cwd status (m,mi) i info =
case info of
@@ -208,7 +208,7 @@ renameTerm env vars = ren vars where
Abs b x t -> liftM (Abs b x) (ren (x:vs) t)
Prod bt x a b -> liftM2 (Prod bt x) (ren vs a) (ren (x:vs) b)
Typed a b -> liftM2 Typed (ren vs a) (ren vs b)
- Vr x
+ Vr x
| elem x vs -> return trm
| otherwise -> renid trm
Cn _ -> renid trm
@@ -219,7 +219,7 @@ renameTerm env vars = ren vars where
i' <- case i of
TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
_ -> return i
- liftM (T i') $ mapM (renCase vs) cs
+ liftM (T i') $ mapM (renCase vs) cs
Let (x,(m,a)) b -> do
m' <- case m of
@@ -229,7 +229,7 @@ renameTerm env vars = ren vars where
b' <- ren (x:vs) b
return $ Let (x,(m',a')) b'
- P t@(Vr r) l -- Here we have $r.l$ and this is ambiguous it could be either
+ P t@(Vr r) l -- Here we have $r.l$ and this is ambiguous it could be either
-- record projection from variable or constant $r$ or qualified expression with module $r$
| elem r vs -> return trm -- try var proj first ..
| otherwise -> checks [ renid' (Q (MN r,label2ident l)) -- .. and qualified expression second.
@@ -331,7 +331,7 @@ renamePattern env patt =
renameContext :: Status -> Context -> Check Context
renameContext b = renc [] where
renc vs cont = case cont of
- (bt,x,t) : xts
+ (bt,x,t) : xts
| isWildIdent x -> do
t' <- ren vs t
xts' <- renc vs xts
diff --git a/src/compiler/GF/Compile/TypeCheck/Abstract.hs b/src/compiler/GF/Compile/TypeCheck/Abstract.hs
index 196e1a646..c76660259 100644
--- a/src/compiler/GF/Compile/TypeCheck/Abstract.hs
+++ b/src/compiler/GF/Compile/TypeCheck/Abstract.hs
@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/09/15 16:22:02 $
+-- > CVS $Date: 2005/09/15 16:22:02 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.16 $
--
@@ -13,11 +13,11 @@
-----------------------------------------------------------------------------
module GF.Compile.TypeCheck.Abstract (-- * top-level type checking functions; TC should not be called directly.
- checkContext,
- checkTyp,
- checkDef,
- checkConstrs,
- ) where
+ checkContext,
+ checkTyp,
+ checkDef,
+ checkConstrs,
+ ) where
import GF.Data.Operations
@@ -33,8 +33,8 @@ import GF.Text.Pretty
--import Control.Monad (foldM, liftM, liftM2)
-- | invariant way of creating TCEnv from context
-initTCEnv gamma =
- (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma)
+initTCEnv gamma =
+ (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma)
-- interface to TC type checker
diff --git a/src/compiler/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/GF/Compile/TypeCheck/Concrete.hs
index 380970405..e9420290a 100644
--- a/src/compiler/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/GF/Compile/TypeCheck/Concrete.hs
@@ -69,7 +69,6 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
lockRecType c t' ---- locking to be removed AR 20/6/2009
_ | ty == typeTok -> return typeStr
- _ | isPredefConstant ty -> return ty
_ -> composOp (comp g) ty
diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
index c32afa7a5..d85af5361 100644
--- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -396,7 +396,7 @@ tcRecTypeFields ge scope ((l,ty):rs) mb_ty = do
return ((l,ty):rs,mb_ty)
-- | Invariant: if the third argument is (Just rho),
--- then rho is in weak-prenex form
+-- then rho is in weak-prenex form
instSigma :: GlobalEnv -> Scope -> Term -> Sigma -> Maybe Rho -> TcM (Term, Rho)
instSigma ge scope t ty1 Nothing = return (t,ty1) -- INST1
instSigma ge scope t ty1 (Just ty2) = do -- INST2
@@ -631,8 +631,8 @@ allBinders = [ identS [x] | x <- ['a'..'z'] ] ++
type Scope = [(Ident,Value)]
type Sigma = Value
-type Rho = Value -- No top-level ForAll
-type Tau = Value -- No ForAlls anywhere
+type Rho = Value -- No top-level ForAll
+type Tau = Value -- No ForAlls anywhere
data MetaValue
= Unbound Scope Sigma
@@ -724,8 +724,8 @@ getMetaVars loc sc_tys = do
go (Vr tv) acc = acc
go (App x y) acc = go x (go y acc)
go (Meta i) acc
- | i `elem` acc = acc
- | otherwise = i : acc
+ | i `elem` acc = acc
+ | otherwise = i : acc
go (Q _) acc = acc
go (QC _) acc = acc
go (Sort _) acc = acc
@@ -742,9 +742,9 @@ getFreeVars loc sc_tys = do
return (foldr (go []) [] tys)
where
go bound (Vr tv) acc
- | tv `elem` bound = acc
- | tv `elem` acc = acc
- | otherwise = tv : acc
+ | tv `elem` bound = acc
+ | tv `elem` acc = acc
+ | otherwise = tv : acc
go bound (App x y) acc = go bound x (go bound y acc)
go bound (Meta _) acc = acc
go bound (Q _) acc = acc
diff --git a/src/compiler/GF/Compile/TypeCheck/TC.hs b/src/compiler/GF/Compile/TypeCheck/TC.hs
index abcb24617..c0df83394 100644
--- a/src/compiler/GF/Compile/TypeCheck/TC.hs
+++ b/src/compiler/GF/Compile/TypeCheck/TC.hs
@@ -5,21 +5,22 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/10/02 20:50:19 $
+-- > CVS $Date: 2005/10/02 20:50:19 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.11 $
--
-- Thierry Coquand's type checking algorithm that creates a trace
-----------------------------------------------------------------------------
-module GF.Compile.TypeCheck.TC (AExp(..),
- Theory,
- checkExp,
- inferExp,
- checkBranch,
- eqVal,
- whnf
- ) where
+module GF.Compile.TypeCheck.TC (
+ AExp(..),
+ Theory,
+ checkExp,
+ inferExp,
+ checkBranch,
+ eqVal,
+ whnf
+ ) where
import GF.Data.Operations
import GF.Grammar
@@ -31,17 +32,17 @@ import Data.Maybe
import GF.Text.Pretty
data AExp =
- AVr Ident Val
+ AVr Ident Val
| ACn QIdent Val
- | AType
- | AInt Int
+ | AType
+ | AInt Int
| AFloat Double
| AStr String
| AMeta MetaId Val
| ALet (Ident,(Val,AExp)) AExp
- | AApp AExp AExp Val
- | AAbs Ident Val AExp
- | AProd Ident AExp AExp
+ | AApp AExp AExp Val
+ | AAbs Ident Val AExp
+ | AProd Ident AExp AExp
-- -- | AEqs [([Exp],AExp)] --- not used
| ARecType [ALabelling]
| AR [AAssign]
@@ -50,7 +51,7 @@ data AExp =
| AData Val
deriving (Eq,Show)
-type ALabelling = (Label, AExp)
+type ALabelling = (Label, AExp)
type AAssign = (Label, (Val, AExp))
type Theory = QIdent -> Err Val
@@ -71,7 +72,7 @@ whnf :: Val -> Err Val
whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug
case v of
VApp u w -> do
- u' <- whnf u
+ u' <- whnf u
w' <- whnf w
app u' w'
VClos env e -> eval env e
@@ -81,9 +82,9 @@ app :: Val -> Val -> Err Val
app u v = case u of
VClos env (Abs _ x e) -> eval ((x,v):env) e
_ -> return $ VApp u v
-
+
eval :: Env -> Term -> Err Val
-eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
+eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
case e of
Vr x -> lookupVar env x
Q c -> return $ VCn c
@@ -95,23 +96,23 @@ eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
_ -> return $ VClos env e
eqVal :: Int -> Val -> Val -> Err [(Val,Val)]
-eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $
+eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $
do
w1 <- whnf u1
- w2 <- whnf u2
+ w2 <- whnf u2
let v = VGen k
case (w1,w2) of
(VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2)
(VClos env1 (Abs _ x1 e1), VClos env2 (Abs _ x2 e2)) ->
eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)
(VClos env1 (Prod _ x1 a1 e1), VClos env2 (Prod _ x2 a2 e2)) ->
- liftM2 (++)
+ liftM2 (++)
(eqVal k (VClos env1 a1) (VClos env2 a2))
(eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2))
(VGen i _, VGen j _) -> return [(w1,w2) | i /= j]
- (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j]
+ (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j]
--- thus ignore qualifications; valid because inheritance cannot
- --- be qualified. Simplifies annotation. AR 17/3/2005
+ --- be qualified. Simplifies annotation. AR 17/3/2005
_ -> return [(w1,w2) | w1 /= w2]
-- invariant: constraints are in whnf
@@ -127,10 +128,10 @@ checkExp th tenv@(k,rho,gamma) e ty = do
Abs _ x t -> case typ of
VClos env (Prod _ y a b) -> do
- a' <- whnf $ VClos env a ---
- (t',cs) <- checkExp th
- (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
- return (AAbs x a' t', cs)
+ a' <- whnf $ VClos env a ---
+ (t',cs) <- checkExp th
+ (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
+ return (AAbs x a' t', cs)
_ -> Bad (render ("function type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ))
Let (x, (mb_typ, e1)) e2 -> do
@@ -150,7 +151,7 @@ checkExp th tenv@(k,rho,gamma) e ty = do
(b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b
return (AProd x a' b', csa ++ csb)
- R xs ->
+ R xs ->
case typ of
VRecType ys -> do case [l | (l,_) <- ys, isNothing (lookup l xs)] of
[] -> return ()
@@ -174,7 +175,7 @@ checkInferExp th tenv@(k,_,_) e typ = do
(e',w,cs1) <- inferExp th tenv e
cs2 <- eqVal k w typ
return (e',cs1 ++ cs2)
-
+
inferExp :: Theory -> TCEnv -> Term -> Err (AExp, Val, [(Val,Val)])
inferExp th tenv@(k,rho,gamma) e = case e of
Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x
@@ -200,13 +201,13 @@ inferExp th tenv@(k,rho,gamma) e = case e of
(e2,val2,cs2) <- inferExp th (k,rho,(x,val1):gamma) e2
return (ALet (x,(val1,e1)) e2, val2, cs1++cs2)
App f t -> do
- (f',w,csf) <- inferExp th tenv f
+ (f',w,csf) <- inferExp th tenv f
typ <- whnf w
case typ of
VClos env (Prod _ x a b) -> do
(a',csa) <- checkExp th tenv t (VClos env a)
- b' <- whnf $ VClos ((x,VClos rho t):env) b
- return $ (AApp f' a' b', b', csf ++ csa)
+ b' <- whnf $ VClos ((x,VClos rho t):env) b
+ return $ (AApp f' a' b', b', csf ++ csa)
_ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
_ -> Bad (render ("cannot infer type of expression" <+> ppTerm Unqualified 0 e))
@@ -232,9 +233,9 @@ checkAssign th tenv@(k,rho,gamma) typs (lbl,(Nothing,exp)) = do
return ((lbl,(val,aexp)),cs)
checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Term],AExp),[(Val,Val)])
-checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
- chB tenv' ps' ty
- where
+checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
+ chB tenv' ps' ty
+ where
(ps',_,rho2,k') = ps2ts k ps
tenv' = (k, rho2++rho, gamma) ---- k' ?
@@ -245,11 +246,11 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
typ <- whnf ty
case typ of
VClos env (Prod _ y a b) -> do
- a' <- whnf $ VClos env a
+ a' <- whnf $ VClos env a
(p', sigma, binds, cs1) <- checkP tenv p y a'
let tenv' = (length binds, sigma ++ rho, binds ++ gamma)
((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b)
- return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
+ return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
_ -> Bad (render ("Product expected for definiens" <+> ppTerm Unqualified 0 t <+> "instead of" <+> ppValue Unqualified 0 typ))
[] -> do
(e,cs) <- checkExp th tenv t ty
@@ -259,15 +260,15 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]]
return (VClos sigma t, sigma, delta, cs)
- ps2ts k = foldr p2t ([],0,[],k)
+ ps2ts k = foldr p2t ([],0,[],k)
p2t p (ps,i,g,k) = case p of
- PW -> (Meta i : ps, i+1,g,k)
+ PW -> (Meta i : ps, i+1,g,k)
PV x -> (Vr x : ps, i, upd x k g,k+1)
PAs x p -> p2t p (ps,i,g,k)
PString s -> (K s : ps, i, g, k)
PInt n -> (EInt n : ps, i, g, k)
PFloat n -> (EFloat n : ps, i, g, k)
- PP c xs -> (mkApp (Q c) xss : ps, j, g',k')
+ PP c xs -> (mkApp (Q c) xss : ps, j, g',k')
where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
PImplArg p -> p2t p (ps,i,g,k)
PTilde t -> (t : ps, i, g, k)
@@ -307,8 +308,8 @@ checkPatt th tenv exp val = do
case typ of
VClos env (Prod _ x a b) -> do
(a',_,csa) <- checkExpP tenv t (VClos env a)
- b' <- whnf $ VClos ((x,VClos rho t):env) b
- return $ (AApp f' a' b', b', csf ++ csa)
+ b' <- whnf $ VClos ((x,VClos rho t):env) b
+ return $ (AApp f' a' b', b', csf ++ csa)
_ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
_ -> Bad (render ("cannot typecheck pattern" <+> ppTerm Unqualified 0 exp))
@@ -321,4 +322,3 @@ mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)])
mkAnnot a ti = do
(v,cs) <- ti
return (a v, v, cs)
-
diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs
index 4399405b8..7bbe1d8dc 100644
--- a/src/compiler/GF/Compile/Update.hs
+++ b/src/compiler/GF/Compile/Update.hs
@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/05/30 18:39:44 $
+-- > CVS $Date: 2005/05/30 18:39:44 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.8 $
--
@@ -34,14 +34,14 @@ buildAnyTree :: Fail.MonadFail m => ModuleName -> [(Ident,Info)] -> m (Map.Map I
buildAnyTree m = go Map.empty
where
go map [] = return map
- go map ((c,j):is) = do
+ go map ((c,j):is) =
case Map.lookup c map of
Just i -> case unifyAnyInfo m i j of
- Ok k -> go (Map.insert c k map) is
- Bad _ -> fail $ render ("conflicting information in module"<+>m $$
- nest 4 (ppJudgement Qualified (c,i)) $$
- "and" $+$
- nest 4 (ppJudgement Qualified (c,j)))
+ Ok k -> go (Map.insert c k map) is
+ Bad _ -> fail $ render ("conflicting information in module"<+>m $$
+ nest 4 (ppJudgement Qualified (c,i)) $$
+ "and" $+$
+ nest 4 (ppJudgement Qualified (c,j)))
Nothing -> go (Map.insert c j map) is
extendModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
@@ -51,14 +51,14 @@ extendModule cwd gr (name,m)
---- Should be replaced by real control. AR 4/2/2005
| mstatus m == MSIncomplete && isModCnc m = return (name,m)
| otherwise = checkInModule cwd m NoLoc empty $ do
- m' <- foldM extOne m (mextend m)
+ m' <- foldM extOne m (mextend m)
return (name,m')
where
extOne mo (n,cond) = do
m0 <- lookupModule gr n
-- test that the module types match, and find out if the old is complete
- unless (sameMType (mtype m) (mtype mo))
+ unless (sameMType (mtype m) (mtype mo))
(checkError ("illegal extension type to module" <+> name))
let isCompl = isCompleteModule m0
@@ -67,7 +67,7 @@ extendModule cwd gr (name,m)
js1 <- extendMod gr isCompl ((n,m0), isInherited cond) name (jments mo)
-- if incomplete, throw away extension information
- return $
+ return $
if isCompl
then mo {jments = js1}
else mo {mextend= filter ((/=n) . fst) (mextend mo)
@@ -75,7 +75,7 @@ extendModule cwd gr (name,m)
,jments = js1
}
--- | rebuilding instance + interface, and "with" modules, prior to renaming.
+-- | rebuilding instance + interface, and "with" modules, prior to renaming.
-- AR 24/10/2003
rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_)) =
@@ -88,8 +88,8 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
-- add the information given in interface into an instance module
Nothing -> do
- unless (null is || mstatus mi == MSIncomplete)
- (checkError ("module" <+> i <+>
+ unless (null is || mstatus mi == MSIncomplete)
+ (checkError ("module" <+> i <+>
"has open interfaces and must therefore be declared incomplete"))
case mt of
MTInstance (i0,mincl) -> do
@@ -113,7 +113,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
let stat' = if all (flip elem infs) is
then MSComplete
else MSIncomplete
- unless (stat' == MSComplete || stat == MSIncomplete)
+ unless (stat' == MSComplete || stat == MSIncomplete)
(checkError ("module" <+> i <+> "remains incomplete"))
ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext
let ops1 = nub $
@@ -141,24 +141,24 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
extendMod :: Grammar ->
Bool -> (Module,Ident -> Bool) -> ModuleName ->
Map.Map Ident Info -> Check (Map.Map Ident Info)
-extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
+extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
where
try new (c,i0)
| not (cond c) = return new
| otherwise = case Map.lookup c new of
Just j -> case unifyAnyInfo name i j of
- Ok k -> return $ Map.insert c k new
- Bad _ -> do (base,j) <- case j of
- AnyInd _ m -> lookupOrigInfo gr (m,c)
- _ -> return (base,j)
- (name,i) <- case i of
+ Ok k -> return $ Map.insert c k new
+ Bad _ -> do (base,j) <- case j of
+ AnyInd _ m -> lookupOrigInfo gr (m,c)
+ _ -> return (base,j)
+ (name,i) <- case i of
AnyInd _ m -> lookupOrigInfo gr (m,c)
_ -> return (name,i)
- checkError ("cannot unify the information" $$
- nest 4 (ppJudgement Qualified (c,i)) $$
- "in module" <+> name <+> "with" $$
- nest 4 (ppJudgement Qualified (c,j)) $$
- "in module" <+> base)
+ checkError ("cannot unify the information" $$
+ nest 4 (ppJudgement Qualified (c,i)) $$
+ "in module" <+> name <+> "with" $$
+ nest 4 (ppJudgement Qualified (c,j)) $$
+ "in module" <+> base)
Nothing-> if isCompl
then return $ Map.insert c (indirInfo name i) new
else return $ Map.insert c i new
@@ -166,11 +166,11 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
i = globalizeLoc (msrc mi) i0
indirInfo :: ModuleName -> Info -> Info
- indirInfo n info = AnyInd b n' where
+ indirInfo n info = AnyInd b n' where
(b,n') = case info of
ResValue _ -> (True,n)
ResParam _ _ -> (True,n)
- AbsFun _ _ Nothing _ -> (True,n)
+ AbsFun _ _ Nothing _ -> (True,n)
AnyInd b k -> (b,k)
_ -> (False,n) ---- canonical in Abs
@@ -194,24 +194,24 @@ globalizeLoc fpath i =
unifyAnyInfo :: ModuleName -> Info -> Info -> Err Info
unifyAnyInfo m i j = case (i,j) of
- (AbsCat mc1, AbsCat mc2) ->
+ (AbsCat mc1, AbsCat mc2) ->
liftM AbsCat (unifyMaybeL mc1 mc2)
- (AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) ->
+ (AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) ->
liftM4 AbsFun (unifyMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) (unifyMaybe moper1 moper2) -- adding defs
(ResParam mt1 mv1, ResParam mt2 mv2) ->
liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2)
- (ResValue (L l1 t1), ResValue (L l2 t2))
+ (ResValue (L l1 t1), ResValue (L l2 t2))
| t1==t2 -> return (ResValue (L l1 t1))
| otherwise -> fail ""
(_, ResOverload ms t) | elem m ms ->
return $ ResOverload ms t
- (ResOper mt1 m1, ResOper mt2 m2) ->
+ (ResOper mt1 m1, ResOper mt2 m2) ->
liftM2 ResOper (unifyMaybeL mt1 mt2) (unifyMaybeL m1 m2)
- (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) ->
+ (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) ->
liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2) (unifyMaybe mpmcfg1 mpmcfg2)
- (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) ->
+ (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) ->
liftM3 (CncFun m) (unifyMaybeL mt1 mt2) (unifyMaybeL md1 md2) (unifyMaybe mpmcfg1 mpmcfg2)
(AnyInd b1 m1, AnyInd b2 m2) -> do