msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Reduced clutter in monadic code

Browse Source 
+ Eliminated vairous ad-hoc coersion functions between specific monads 
  (IO, Err, IOE, Check) in favor of more general lifting functions
  (liftIO, liftErr).
+ Generalized many basic monadic operations from specific monads to
  arbitrary monads in the appropriate class (MonadIO and/or ErrorMonad),
  thereby completely eliminating the need for lifting functions in lots
  of places.

This can be considered a small step forward towards a cleaner
compiler API and more malleable compiler code in general.
This commit is contained in:
hallgren
2013-11-20 00:45:33 +00:00
parent c29326d074
commit c8cbd4477f
21 changed files with 196 additions and 214 deletions
Download Patch File Download Diff File Expand all files Collapse all files

12
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -50,10 +50,10 @@ checkModule opts sgr mo@(m,mi) = do
checkRestrictedInheritance sgr mo
mo <- case mtype mi of
MTConcrete a -> do let gr = prependModule sgr mo
abs <- checkErr $ lookupModule gr a
abs <- lookupModule gr a
checkCompleteGrammar opts gr (a,abs) mo
_ -> return mo
infoss <- checkErr $ topoSortJments2 mo
infoss <- topoSortJments2 mo
foldM updateCheckInfos mo infoss
where
updateCheckInfos mo = fmap (foldl update mo) . parallelCheck . map check
@@ -246,7 +246,7 @@ checkInfo opts sgr (m,mo) c info = do
ResOverload os tysts -> chIn NoLoc "overloading" $ do
tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gr [] t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts -- return explicit ones
tysts0 <- checkErr $ lookupOverload gr (m,c) -- check against inherited ones too
tysts0 <- lookupOverload gr (m,c) -- check against inherited ones too
tysts1 <- mapM (uncurry $ flip (checkLType gr []))
[(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
--- this can only be a partial guarantee, since matching
@@ -267,7 +267,7 @@ checkInfo opts sgr (m,mo) c info = do
nest 2 (text "Happened in" <+> text cat <+> ppIdent c))
mkPar (f,co) = do
vs <- checkErr $ liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
vs <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
return $ map (mkApp (QC (m,f))) vs
checkUniq xss = case xss of
@@ -317,13 +317,13 @@ linTypeOfType cnc m typ = do
let vars = mkRecType varLabel $ replicate n typeStr
symb = argIdent n cat i
rec <- if n==0 then return val else
checkErr $ errIn (render (text "extending" $$
errIn (render (text "extending" $$
nest 2 (ppTerm Unqualified 0 vars) $$
text "with" $$
nest 2 (ppTerm Unqualified 0 val))) $
plusRecType vars val
return (Explicit,symb,rec)
lookLin (_,c) = checks [ --- rather: update with defLinType ?
checkErr (lookupLincat cnc m c) >>= computeLType cnc []
lookupLincat cnc m c >>= computeLType cnc []
,return defLinType
]