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 ddac5f9e5a
commit 018c9838ed
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/Grammar/CF.hs
View File

@@ -28,14 +28,14 @@ import Data.Char
import Data.List
--import System.FilePath
getCF :: FilePath -> String -> Err SourceGrammar
getCF :: ErrorMonad m => FilePath -> String -> m SourceGrammar
getCF fpath = fmap (cf2gf fpath . uniqueFuns) . pCF
---------------------
-- the parser -------
---------------------
pCF :: String -> Err CF
pCF :: ErrorMonad m => String -> m CF
pCF s = do
rules <- mapM getCFRule $ filter isRule $ lines s
return $ concat rules
@@ -48,14 +48,14 @@ pCF s = do
-- fun. C -> item1 item2 ... where unquoted items are treated as cats
-- Actually would be nice to add profiles to this.
getCFRule :: String -> Err [CFRule]
getCFRule :: ErrorMonad m => String -> m [CFRule]
getCFRule s = getcf (wrds s) where
getcf ws = case ws of
fun : cat : a : its | isArrow a ->
Ok [L NoLoc (init fun, (cat, map mkIt its))]
return [L NoLoc (init fun, (cat, map mkIt its))]
cat : a : its | isArrow a ->
Ok [L NoLoc (mkFun cat it, (cat, map mkIt it)) | it <- chunk its]
_ -> Bad (" invalid rule:" +++ s)
return [L NoLoc (mkFun cat it, (cat, map mkIt it)) | it <- chunk its]
_ -> raise (" invalid rule:" +++ s)
isArrow a = elem a ["->", "::="]
mkIt w = case w of
('"':w@(_:_)) -> Right (init w)

8
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -195,17 +195,17 @@ mGrammar ms = MGrammar (Map.fromList ms) ms
-- | we store the module type with the identifier
abstractOfConcrete :: SourceGrammar -> Ident -> Err Ident
abstractOfConcrete :: ErrorMonad m => SourceGrammar -> Ident -> m Ident
abstractOfConcrete gr c = do
n <- lookupModule gr c
case mtype n of
MTConcrete a -> return a
_ -> Bad $ render (text "expected concrete" <+> ppIdent c)
_ -> raise $ render (text "expected concrete" <+> ppIdent c)
lookupModule :: SourceGrammar -> Ident -> Err SourceModInfo
lookupModule :: ErrorMonad m => SourceGrammar -> Ident -> m SourceModInfo
lookupModule gr m = case Map.lookup m (moduleMap gr) of
Just i -> return i
Nothing -> Bad $ render (text "unknown module" <+> ppIdent m <+> text "among" <+> hsep (map (ppIdent . fst) (modules gr)))
Nothing -> raise $ render (text "unknown module" <+> ppIdent m <+> text "among" <+> hsep (map (ppIdent . fst) (modules gr)))
isModAbs :: SourceModInfo -> Bool
isModAbs m =

4
src/compiler/GF/Grammar/Lockfield.hs
View File

@@ -20,9 +20,9 @@ import GF.Infra.Ident
import GF.Grammar.Grammar
import GF.Grammar.Macros
import GF.Data.Operations
import GF.Data.Operations(ErrorMonad,Err(..))
lockRecType :: Ident -> Type -> Err Type
lockRecType :: ErrorMonad m => Ident -> Type -> m Type
lockRecType c t@(RecType rs) =
let lab = lockLabel c in
return $ if elem lab (map fst rs) || elem (showIdent c) ["String","Int"]

44
src/compiler/GF/Grammar/Lookup.hs
View File

@@ -50,19 +50,19 @@ lock c = lockRecType c -- return
unlock c = unlockRecord c -- return
-- to look up a constant etc in a search tree --- why here? AR 29/5/2008
lookupIdent :: Ident -> BinTree Ident b -> Err b
lookupIdent :: ErrorMonad m => Ident -> BinTree Ident b -> m b
lookupIdent c t =
case lookupTree showIdent c t of
Ok v -> return v
Bad _ -> Bad ("unknown identifier" +++ showIdent c)
Bad _ -> raise ("unknown identifier" +++ showIdent c)
lookupIdentInfo :: SourceModInfo -> Ident -> Err Info
lookupIdentInfo :: ErrorMonad m => SourceModInfo -> Ident -> m Info
lookupIdentInfo mo i = lookupIdent i (jments mo)
lookupQIdentInfo :: SourceGrammar -> QIdent -> Err Info
lookupQIdentInfo :: ErrorMonad m => SourceGrammar -> QIdent -> m Info
lookupQIdentInfo gr (m,c) = flip lookupIdentInfo c =<< lookupModule gr m
lookupResDef :: SourceGrammar -> QIdent -> Err Term
lookupResDef :: ErrorMonad m => SourceGrammar -> QIdent -> m Term
lookupResDef gr x = fmap unLoc (lookupResDefLoc gr x)
lookupResDefLoc gr (m,c)
@@ -83,9 +83,9 @@ lookupResDefLoc gr (m,c)
AnyInd _ n -> look n c
ResParam _ _ -> return (noLoc (QC (m,c)))
ResValue _ -> return (noLoc (QC (m,c)))
_ -> Bad $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m)
_ -> raise $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m)
lookupResType :: SourceGrammar -> QIdent -> Err Type
lookupResType :: ErrorMonad m => SourceGrammar -> QIdent -> m Type
lookupResType gr (m,c) = do
info <- lookupQIdentInfo gr (m,c)
case info of
@@ -99,9 +99,9 @@ lookupResType gr (m,c) = do
AnyInd _ n -> lookupResType gr (n,c)
ResParam _ _ -> return typePType
ResValue (L _ t) -> return t
_ -> Bad $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m)
_ -> raise $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m)
lookupOverload :: SourceGrammar -> QIdent -> Err [([Type],(Type,Term))]
lookupOverload :: ErrorMonad m => SourceGrammar -> QIdent -> m [([Type],(Type,Term))]
lookupOverload gr (m,c) = do
info <- lookupQIdentInfo gr (m,c)
case info of
@@ -112,10 +112,10 @@ lookupOverload gr (m,c) = do
concat tss
AnyInd _ n -> lookupOverload gr (n,c)
_ -> Bad $ render (ppIdent c <+> text "is not an overloaded operation")
_ -> raise $ render (ppIdent c <+> text "is not an overloaded operation")
-- | returns the original 'Info' and the module where it was found
lookupOrigInfo :: SourceGrammar -> QIdent -> Err (Ident,Info)
lookupOrigInfo :: ErrorMonad m => SourceGrammar -> QIdent -> m (Ident,Info)
lookupOrigInfo gr (m,c) = do
info <- lookupQIdentInfo gr (m,c)
case info of
@@ -127,14 +127,14 @@ allOrigInfos gr m = errVal [] $ do
mo <- lookupModule gr m
return [((m,c),i) | (c,_) <- tree2list (jments mo), Ok (m,i) <- [lookupOrigInfo gr (m,c)]]
lookupParamValues :: SourceGrammar -> QIdent -> Err [Term]
lookupParamValues :: ErrorMonad m => SourceGrammar -> QIdent -> m [Term]
lookupParamValues gr c = do
(_,info) <- lookupOrigInfo gr c
case info of
ResParam _ (Just pvs) -> return pvs
_ -> Bad $ render (ppQIdent Qualified c <+> text "has no parameter values defined")
_ -> raise $ render (ppQIdent Qualified c <+> text "has no parameter values defined")
allParamValues :: SourceGrammar -> Type -> Err [Term]
allParamValues :: ErrorMonad m => SourceGrammar -> Type -> m [Term]
allParamValues cnc ptyp =
case ptyp of
_ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]]
@@ -148,12 +148,12 @@ allParamValues cnc ptyp =
pvs <- allParamValues cnc pt
vvs <- allParamValues cnc vt
return [V pt ts | ts <- combinations (replicate (length pvs) vvs)]
_ -> Bad (render (text "cannot find parameter values for" <+> ppTerm Unqualified 0 ptyp))
_ -> raise (render (text "cannot find parameter values for" <+> ppTerm Unqualified 0 ptyp))
where
-- to normalize records and record types
sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Int,Maybe [Equation])
lookupAbsDef :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m (Maybe Int,Maybe [Equation])
lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c)) $ do
info <- lookupQIdentInfo gr (m,c)
case info of
@@ -161,32 +161,32 @@ lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c))
AnyInd _ n -> lookupAbsDef gr n c
_ -> return (Nothing,Nothing)
lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type
lookupLincat :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Type
lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
lookupLincat gr m c = do
info <- lookupQIdentInfo gr (m,c)
case info of
CncCat (Just (L _ t)) _ _ _ _ -> return t
AnyInd _ n -> lookupLincat gr n c
_ -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
_ -> raise (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
-- | this is needed at compile time
lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type
lookupFunType :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Type
lookupFunType gr m c = do
info <- lookupQIdentInfo gr (m,c)
case info of
AbsFun (Just (L _ t)) _ _ _ -> return t
AnyInd _ n -> lookupFunType gr n c
_ -> Bad (render (text "cannot find type of" <+> ppIdent c))
_ -> raise (render (text "cannot find type of" <+> ppIdent c))
-- | this is needed at compile time
lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context
lookupCatContext :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Context
lookupCatContext gr m c = do
info <- lookupQIdentInfo gr (m,c)
case info of
AbsCat (Just (L _ co)) -> return co
AnyInd _ n -> lookupCatContext gr n c
_ -> Bad (render (text "unknown category" <+> ppIdent c))
_ -> raise (render (text "unknown category" <+> ppIdent c))
-- this gives all opers and param constructors, also overloaded opers and funs, and the types, and locations

22
src/compiler/GF/Grammar/Macros.hs
View File

@@ -262,22 +262,22 @@ mkWildCases = mkCases identW
mkFunType :: [Type] -> Type -> Type
mkFunType tt t = mkProd [(Explicit,identW, ty) | ty <- tt] t [] -- nondep prod
plusRecType :: Type -> Type -> Err Type
--plusRecType :: Type -> Type -> Err Type
plusRecType t1 t2 = case (t1, t2) of
(RecType r1, RecType r2) -> case
filter (`elem` (map fst r1)) (map fst r2) of
[] -> return (RecType (r1 ++ r2))
ls -> fail $ render (text "clashing labels" <+> hsep (map ppLabel ls))
_ -> fail $ render (text "cannot add record types" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2)
ls -> raise $ render (text "clashing labels" <+> hsep (map ppLabel ls))
_ -> raise $ render (text "cannot add record types" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2)
plusRecord :: Term -> Term -> Err Term
--plusRecord :: Term -> Term -> Err Term
plusRecord t1 t2 =
case (t1,t2) of
(R r1, R r2 ) -> return (R ([(l,v) | -- overshadowing of old fields
(l,v) <- r1, not (elem l (map fst r2)) ] ++ r2))
(_, FV rs) -> mapM (plusRecord t1) rs >>= return . FV
(FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV
_ -> fail $ render (text "cannot add records" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2)
_ -> raise $ render (text "cannot add records" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2)
-- | default linearization type
defLinType :: Type
@@ -444,7 +444,7 @@ strsFromTerm t = case t of
]
FV ts -> mapM strsFromTerm ts >>= return . concat
Strs ts -> mapM strsFromTerm ts >>= return . concat
_ -> fail (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t))
_ -> raise (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t))
-- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg
stringFromTerm :: Term -> String
@@ -599,20 +599,20 @@ allDependencies ism b =
AbsCat (Just (L loc co)) -> [Just (L loc ty) | (_,_,ty) <- co]
_ -> []
topoSortJments :: SourceModule -> Err [(Ident,Info)]
topoSortJments :: ErrorMonad m => SourceModule -> m [(Ident,Info)]
topoSortJments (m,mi) = do
is <- either
return
(\cyc -> Bad (render (text "circular definitions:" <+> fsep (map ppIdent (head cyc)))))
(\cyc -> raise (render (text "circular definitions:" <+> fsep (map ppIdent (head cyc)))))
(topoTest (allDependencies (==m) (jments mi)))
return (reverse [(i,info) | i <- is, Ok info <- [lookupTree showIdent i (jments mi)]])
topoSortJments2 :: SourceModule -> Err [[(Ident,Info)]]
topoSortJments2 :: ErrorMonad m => SourceModule -> m [[(Ident,Info)]]
topoSortJments2 (m,mi) = do
iss <- either
return
(\cyc -> fail (render (text "circular definitions:"
<+> fsep (map ppIdent (head cyc)))))
(\cyc -> raise (render (text "circular definitions:"
<+> fsep (map ppIdent (head cyc)))))
(topoTest2 (allDependencies (==m) (jments mi)))
return
[[(i,info) | i<-is,Ok info<-[lookupTree showIdent i (jments mi)]] | is<-iss]

18
src/compiler/GF/Grammar/PatternMatch.hs
View File

@@ -29,10 +29,10 @@ import Control.Monad
import Text.PrettyPrint
--import Debug.Trace
matchPattern :: [(Patt,rhs)] -> Term -> Err (rhs, Substitution)
matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution)
matchPattern pts term =
if not (isInConstantForm term)
then Bad (render (text "variables occur in" <+> ppTerm Unqualified 0 term))
then raise (render (text "variables occur in" <+> ppTerm Unqualified 0 term))
else do
term' <- mkK term
errIn (render (text "trying patterns" <+> hsep (punctuate comma (map (ppPatt Unqualified 0 . fst) pts)))) $
@@ -49,20 +49,20 @@ matchPattern pts term =
K w -> return [w]
C v w -> liftM2 (++) (getS v) (getS w)
Empty -> return []
_ -> Bad (render (text "cannot get string from" <+> ppTerm Unqualified 0 s))
_ -> raise (render (text "cannot get string from" <+> ppTerm Unqualified 0 s))
testOvershadow :: [Patt] -> [Term] -> Err [Patt]
testOvershadow :: ErrorMonad m => [Patt] -> [Term] -> m [Patt]
testOvershadow pts vs = do
let numpts = zip pts [0..]
let cases = [(p,EInt i) | (p,i) <- numpts]
ts <- mapM (liftM fst . matchPattern cases) vs
return [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ]
findMatch :: [([Patt],rhs)] -> [Term] -> Err (rhs, Substitution)
findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution)
findMatch cases terms = case cases of
[] -> Bad (render (text "no applicable case for" <+> hsep (punctuate comma (map (ppTerm Unqualified 0) terms))))
[] -> raise (render (text "no applicable case for" <+> hsep (punctuate comma (map (ppTerm Unqualified 0) terms))))
(patts,_):_ | length patts /= length terms ->
Bad (render (text "wrong number of args for patterns :" <+> hsep (map (ppPatt Unqualified 0) patts) <+>
raise (render (text "wrong number of args for patterns :" <+> hsep (map (ppPatt Unqualified 0) patts) <+>
text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms)))
(patts,val):cc -> case mapM tryMatch (zip patts terms) of
Ok substs -> return (val, concat substs)
@@ -116,7 +116,7 @@ tryMatch (p,t) = do
(PNeg p',_) -> case tryMatch (p',t) of
Bad _ -> return []
_ -> Bad (render (text "no match with negative pattern" <+> ppPatt Unqualified 0 p))
_ -> raise (render (text "no match with negative pattern" <+> ppPatt Unqualified 0 p))
(PSeq p1 p2, ([],K s, [])) -> matchPSeq p1 p2 s
(PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s
@@ -130,7 +130,7 @@ tryMatch (p,t) = do
(PChar, ([],K [_], [])) -> return []
(PChars cs, ([],K [c], [])) | elem c cs -> return []
_ -> Bad (render (text "no match in case expr for" <+> ppTerm Unqualified 0 t))
_ -> raise (render (text "no match in case expr for" <+> ppTerm Unqualified 0 t))
matchPMSeq (m1,p1) (m2,p2) s = matchPSeq' m1 p1 m2 p2 s
--matchPSeq p1 p2 s = matchPSeq' (0,maxBound::Int) p1 (0,maxBound::Int) p2 s