diff options
Diffstat (limited to 'src/compiler')
26 files changed, 368 insertions, 182 deletions
diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index 72e57fcf5..2f2e802e0 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances, CPP #-} module GF.Command.Commands ( PGFEnv,HasPGFEnv(..),pgf,mos,pgfEnv,pgfCommands, options,flags, @@ -34,6 +34,7 @@ import Data.Maybe import qualified Data.Map as Map import GF.Text.Pretty import Data.List (sort) +import qualified Control.Monad.Fail as Fail --import Debug.Trace @@ -44,7 +45,7 @@ pgfEnv pgf = Env pgf mos class (Functor m,Monad m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv -instance (Monad m,HasPGFEnv m) => TypeCheckArg m where +instance (Monad m,HasPGFEnv m,Fail.MonadFail m) => TypeCheckArg m where typeCheckArg e = (either (fail . render . ppTcError) (return . fst) . flip inferExpr e . pgf) =<< getPGFEnv @@ -740,7 +741,7 @@ pgfCommands = Map.fromList [ Nothing -> do putStrLn ("unknown category of function identifier "++show id) return void [e] -> case inferExpr pgf e of - Left tcErr -> error $ render (ppTcError tcErr) + Left tcErr -> errorWithoutStackTrace $ render (ppTcError tcErr) Right (e,ty) -> do putStrLn ("Expression: "++showExpr [] e) putStrLn ("Type: "++showType [] ty) putStrLn ("Probability: "++show (probTree pgf e)) @@ -1018,3 +1019,7 @@ stanzas = map unlines . chop . lines where chop ls = case break (=="") ls of (ls1,[]) -> [ls1] (ls1,_:ls2) -> ls1 : chop ls2 + +#if !(MIN_VERSION_base(4,9,0)) +errorWithoutStackTrace = error +#endif
\ No newline at end of file diff --git a/src/compiler/GF/Command/Commands2.hs b/src/compiler/GF/Command/Commands2.hs index 344b6b51d..100f877a9 100644 --- a/src/compiler/GF/Command/Commands2.hs +++ b/src/compiler/GF/Command/Commands2.hs @@ -18,6 +18,7 @@ import Data.Maybe import qualified Data.Map as Map import GF.Text.Pretty import Control.Monad(mplus) +import qualified Control.Monad.Fail as Fail data PGFEnv = Env {pgf::Maybe PGF,concs::Map.Map ConcName Concr} @@ -25,7 +26,7 @@ data PGFEnv = Env {pgf::Maybe PGF,concs::Map.Map ConcName Concr} pgfEnv pgf = Env (Just pgf) (languages pgf) emptyPGFEnv = Env Nothing Map.empty -class (Monad m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv +class (Fail.MonadFail m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv instance (Monad m,HasPGFEnv m) => TypeCheckArg m where typeCheckArg e = do env <- getPGFEnv diff --git a/src/compiler/GF/Command/Interpreter.hs b/src/compiler/GF/Command/Interpreter.hs index bcb15d238..1c38edf8b 100644 --- a/src/compiler/GF/Command/Interpreter.hs +++ b/src/compiler/GF/Command/Interpreter.hs @@ -11,6 +11,8 @@ import GF.Infra.UseIO(putStrLnE) import Control.Monad(when) import qualified Data.Map as Map +import GF.Infra.UseIO (Output) +import qualified Control.Monad.Fail as Fail data CommandEnv m = CommandEnv { commands :: Map.Map String (CommandInfo m), @@ -22,6 +24,7 @@ data CommandEnv m = CommandEnv { mkCommandEnv cmds = CommandEnv cmds Map.empty Map.empty --interpretCommandLine :: CommandEnv -> String -> SIO () +interpretCommandLine :: (Fail.MonadFail m, Output m, TypeCheckArg m) => CommandEnv m -> String -> m () interpretCommandLine env line = case readCommandLine line of Just [] -> return () diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew.hs b/src/compiler/GF/Compile/Compute/ConcreteNew.hs index a9ae63960..6f00c45e1 100644 --- a/src/compiler/GF/Compile/Compute/ConcreteNew.hs +++ b/src/compiler/GF/Compile/Compute/ConcreteNew.hs @@ -291,9 +291,17 @@ glue env (v1,v2) = glu v1 v2 vt v = case value2term loc (local env) v of Left i -> Error ('#':show i) Right t -> t - in error . render $ - ppL loc (hang "unsupported token gluing:" 4 - (Glue (vt v1) (vt v2))) + originalMsg = render $ ppL loc (hang "unsupported token gluing" 4 + (Glue (vt v1) (vt v2))) + term = render $ pp $ Glue (vt v1) (vt v2) + in error $ unlines + [originalMsg + ,"" + ,"There was a problem in the expression `"++term++"`, either:" + ,"1) You are trying to use + on runtime arguments, possibly via an oper." + ,"2) One of the arguments in `"++term++"` is a bound variable from pattern matching a string, but the cases are non-exhaustive." + ,"For more help see https://github.com/GrammaticalFramework/gf-core/tree/master/doc/errors/gluing.md" + ] -- | to get a string from a value that represents a sequence of terminals @@ -520,7 +528,7 @@ value2term' stop loc xs v0 = -- VGlue v1 v2 -> Glue (v2t v1) (v2t v2) -- VExtR v1 v2 -> ExtR (v2t v1) (v2t v2) VError err -> return (Error err) - _ -> bug ("value2term "++show loc++" : "++show v0) + where v2t = v2txs xs v2txs = value2term' stop loc @@ -546,7 +554,7 @@ value2term' stop loc xs v0 = linPattVars p = if null dups then return pvs - else fail.render $ hang "Pattern is not linear:" 4 (ppPatt Unqualified 0 p) + else fail.render $ hang "Pattern is not linear. All variable names on the left-hand side must be distinct." 4 (ppPatt Unqualified 0 p) where allpvs = allPattVars p pvs = nub allpvs diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index f0c256775..ab6476b31 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -41,6 +41,7 @@ import Control.Monad import Control.Monad.Identity --import Control.Exception --import Debug.Trace(trace) +import qualified Control.Monad.Fail as Fail ---------------------------------------------------------------------- -- main conversion function @@ -196,6 +197,9 @@ newtype CnvMonad a = CM {unCM :: SourceGrammar -> ([ProtoFCat],[Symbol]) -> Branch b} +instance Fail.MonadFail CnvMonad where + fail = bug + instance Applicative CnvMonad where pure = return (<*>) = ap @@ -614,6 +618,23 @@ mkArray lst = listArray (0,length lst-1) lst mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map] bug msg = ppbug msg -ppbug msg = error . render $ hang "Internal error in GeneratePMCFG:" 4 msg +ppbug msg = error completeMsg + where + originalMsg = render $ hang "Internal error in GeneratePMCFG:" 4 msg + completeMsg = + case render msg of -- the error message for pattern matching a runtime string + "descend (CStr 0,CNil,CProj (LIdent (Id {rawId2utf8 = \"s\"})) CNil)" + -> unlines [originalMsg -- add more helpful output + ,"" + ,"1) Check that you are not trying to pattern match a /runtime string/." + ," These are illegal:" + ," lin Test foo = case foo.s of {" + ," \"str\" => … } ; <- explicit matching argument of a lin" + ," lin Test foo = opThatMatches foo <- calling an oper that pattern matches" + ,"" + ,"2) Not about pattern matching? Submit a bug report and we update the error message." + ," https://github.com/GrammaticalFramework/gf-core/issues" + ] + _ -> originalMsg -- any other message: just print it as is ppU = ppTerm Unqualified diff --git a/src/compiler/GF/Compile/PGFtoHaskell.hs b/src/compiler/GF/Compile/PGFtoHaskell.hs index fc17e4e4e..bc8e59f57 100644 --- a/src/compiler/GF/Compile/PGFtoHaskell.hs +++ b/src/compiler/GF/Compile/PGFtoHaskell.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/06/17 12:39:07 $ +-- > CVS $Date: 2005/06/17 12:39:07 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.8 $ -- @@ -22,54 +22,65 @@ import PGF.Internal import GF.Data.Operations import GF.Infra.Option -import Data.List --(isPrefixOf, find, intersperse) +import Data.List(isPrefixOf,find,intercalate,intersperse,groupBy,sortBy) import qualified Data.Map as Map type Prefix = String -> String +type DerivingClause = String -- | the main function grammar2haskell :: Options -> String -- ^ Module name. -> PGF -> String -grammar2haskell opts name gr = foldr (++++) [] $ - pragmas ++ haskPreamble gadt name ++ [types, gfinstances gId lexical gr'] ++ compos +grammar2haskell opts name gr = foldr (++++) [] $ + pragmas ++ haskPreamble gadt name derivingClause (extraImports ++ pgfImports) ++ + [types, gfinstances gId lexical gr'] ++ compos where gr' = hSkeleton gr gadt = haskellOption opts HaskellGADT + dataExt = haskellOption opts HaskellData + pgf2 = haskellOption opts HaskellPGF2 lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat - gId | haskellOption opts HaskellNoPrefix = id - | otherwise = ("G"++) - pragmas | gadt = ["{-# OPTIONS_GHC -fglasgow-exts #-}","{-# LANGUAGE GADTs #-}"] + gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars + | otherwise = ("G"++) . rmForbiddenChars + -- GF grammars allow weird identifier names inside '', e.g. 'VP/Object' + rmForbiddenChars = filter (`notElem` "'!#$%&*+./<=>?@\\^|-~") + pragmas | gadt = ["{-# LANGUAGE GADTs, FlexibleInstances, KindSignatures, RankNTypes, TypeSynonymInstances #-}"] + | dataExt = ["{-# LANGUAGE DeriveDataTypeable #-}"] | otherwise = [] + derivingClause + | dataExt = "deriving (Show,Data)" + | otherwise = "deriving Show" + extraImports | gadt = ["import Control.Monad.Identity", "import Data.Monoid"] + | dataExt = ["import Data.Data"] + | otherwise = [] + pgfImports | pgf2 = ["import PGF2 hiding (Tree)", "", "showCId :: CId -> String", "showCId = id"] + | otherwise = ["import PGF hiding (Tree)"] types | gadt = datatypesGADT gId lexical gr' - | otherwise = datatypes gId lexical gr' + | otherwise = datatypes gId derivingClause lexical gr' compos | gadt = prCompos gId lexical gr' ++ composClass | otherwise = [] -haskPreamble gadt name = +haskPreamble :: Bool -> String -> String -> [String] -> [String] +haskPreamble gadt name derivingClause imports = [ "module " ++ name ++ " where", "" - ] ++ - (if gadt then [ - "import Control.Monad.Identity", - "import Data.Monoid" - ] else []) ++ - [ - "import PGF hiding (Tree)", + ] ++ imports ++ [ + "", "----------------------------------------------------", "-- automatic translation from GF to Haskell", "----------------------------------------------------", - "", + "", "class Gf a where", " gf :: a -> Expr", " fg :: Expr -> a", "", - predefInst gadt "GString" "String" "unStr" "mkStr", + predefInst gadt derivingClause "GString" "String" "unStr" "mkStr", "", - predefInst gadt "GInt" "Int" "unInt" "mkInt", + predefInst gadt derivingClause "GInt" "Int" "unInt" "mkInt", "", - predefInst gadt "GFloat" "Double" "unFloat" "mkFloat", + predefInst gadt derivingClause "GFloat" "Double" "unFloat" "mkFloat", "", "----------------------------------------------------", "-- below this line machine-generated", @@ -77,11 +88,12 @@ haskPreamble gadt name = "" ] -predefInst gadt gtyp typ destr consr = +predefInst :: Bool -> String -> String -> String -> String -> String -> String +predefInst gadt derivingClause gtyp typ destr consr = (if gadt - then [] - else ("newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show\n\n") - ) + then [] + else "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n" + ) ++ "instance Gf" +++ gtyp +++ "where" ++++ " gf (" ++ gtyp +++ "x) =" +++ consr +++ "x" ++++ @@ -94,24 +106,24 @@ type OIdent = String type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] -datatypes :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String -datatypes gId lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId lexical)) . snd +datatypes :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (String,HSkeleton) -> String +datatypes gId derivingClause lexical = foldr (+++++) "" . filter (/="") . map (hDatatype gId derivingClause lexical) . snd gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String -gfinstances gId lexical (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId lexical m)) g +gfinstances gId lexical (m,g) = foldr (+++++) "" $ filter (/="") $ map (gfInstance gId lexical m) g -hDatatype :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String -hDatatype _ _ ("Cn",_) = "" --- -hDatatype gId _ (cat,[]) = "data" +++ gId cat -hDatatype gId _ (cat,rules) | isListCat (cat,rules) = - "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]" - +++ "deriving Show" -hDatatype gId lexical (cat,rules) = +hDatatype :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String +hDatatype _ _ _ ("Cn",_) = "" --- +hDatatype gId _ _ (cat,[]) = "data" +++ gId cat +hDatatype gId derivingClause _ (cat,rules) | isListCat (cat,rules) = + "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]" + +++ derivingClause +hDatatype gId derivingClause lexical (cat,rules) = "data" +++ gId cat +++ "=" ++ (if length rules == 1 then "" else "\n ") +++ foldr1 (\x y -> x ++ "\n |" +++ y) constructors ++++ - " deriving Show" + " " +++ derivingClause where constructors = [gId f +++ foldr (+++) "" (map (gId) xx) | (f,xx) <- nonLexicalRules (lexical cat) rules] ++ if lexical cat then [lexicalConstructor cat +++ "String"] else [] @@ -123,16 +135,17 @@ nonLexicalRules True rules = [r | r@(f,t) <- rules, not (null t)] lexicalConstructor :: OIdent -> String lexicalConstructor cat = "Lex" ++ cat +predefTypeSkel :: HSkeleton predefTypeSkel = [(c,[]) | c <- ["String", "Int", "Float"]] -- GADT version of data types datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String -datatypesGADT gId lexical (_,skel) = unlines $ +datatypesGADT gId lexical (_,skel) = unlines $ concatMap (hCatTypeGADT gId) (skel ++ predefTypeSkel) ++ - [ - "", + [ + "", "data Tree :: * -> * where" - ] ++ + ] ++ concatMap (map (" "++) . hDatatypeGADT gId lexical) skel ++ [ " GString :: String -> Tree GString_", @@ -156,23 +169,23 @@ hCatTypeGADT gId (cat,rules) "data"+++gId cat++"_"] hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String] -hDatatypeGADT gId lexical (cat, rules) +hDatatypeGADT gId lexical (cat, rules) | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t] | otherwise = - [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t + [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t | (f,args) <- nonLexicalRules (lexical cat) rules ] ++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else [] where t = "Tree" +++ gId cat ++ "_" hEqGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String] hEqGADT gId lexical (cat, rules) - | isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs] + | isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs] | otherwise = ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ eqs r | r <- nonLexicalRules (lexical cat) rules] ++ if lexical cat then ["(" ++ lexicalConstructor cat +++ "x" ++ "," ++ lexicalConstructor cat +++ "y" ++ ") -> x == y"] else [] where patt s (f,xs) = unwords (gId f : mkSVars s (length xs)) - eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y | + eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y | (x,y) <- zip (mkSVars "x" (length xs)) (mkSVars "y" (length xs)) ] ++ ["]"]) listr c = (c,["foo"]) -- foo just for length = 1 listeqs = "and [x == y | (x,y) <- zip x1 y1]" @@ -181,25 +194,26 @@ prCompos :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> [String] prCompos gId lexical (_,catrules) = ["instance Compos Tree where", " compos r a f t = case t of"] - ++ + ++ [" " ++ prComposCons (gId f) xs | (c,rs) <- catrules, not (isListCat (c,rs)), - (f,xs) <- rs, not (null xs)] - ++ + (f,xs) <- rs, not (null xs)] + ++ [" " ++ prComposCons (gId c) ["x1"] | (c,rs) <- catrules, isListCat (c,rs)] - ++ + ++ [" _ -> r t"] where - prComposCons f xs = let vs = mkVars (length xs) in + prComposCons f xs = let vs = mkVars (length xs) in f +++ unwords vs +++ "->" +++ rhs f (zip vs xs) rhs f vcs = "r" +++ f +++ unwords (map (prRec f) vcs) - prRec f (v,c) + prRec f (v,c) | isList f = "`a` foldr (a . a (r (:)) . f) (r [])" +++ v | otherwise = "`a`" +++ "f" +++ v - isList f = (gId "List") `isPrefixOf` f + isList f = gId "List" `isPrefixOf` f gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs +hInstance :: (String -> String) -> (String -> Bool) -> String -> (String, [(OIdent, [OIdent])]) -> String ----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004 hInstance gId _ m (cat,[]) = unlines [ "instance Show" +++ gId cat, @@ -208,15 +222,15 @@ hInstance gId _ m (cat,[]) = unlines [ " gf _ = undefined", " fg _ = undefined" ] -hInstance gId lexical m (cat,rules) +hInstance gId lexical m (cat,rules) | isListCat (cat,rules) = "instance Gf" +++ gId cat +++ "where" ++++ - " gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" + " gf (" ++ gId cat +++ "[" ++ intercalate "," baseVars ++ "])" +++ "=" +++ mkRHS ("Base"++ec) baseVars ++++ - " gf (" ++ gId cat +++ "(x:xs)) = " - ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")] + " gf (" ++ gId cat +++ "(x:xs)) = " + ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")] -- no show for GADTs --- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" +-- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" | otherwise = "instance Gf" +++ gId cat +++ "where\n" ++ unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] @@ -225,19 +239,22 @@ hInstance gId lexical m (cat,rules) ec = elemCat cat baseVars = mkVars (baseSize (cat,rules)) mkInst f xx = let xx' = mkVars (length xx) in " gf " ++ - (if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++ + (if null xx then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++ "=" +++ mkRHS f xx' - mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++ - "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]" + mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++ + "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]" +mkVars :: Int -> [String] mkVars = mkSVars "x" + +mkSVars :: String -> Int -> [String] mkSVars s n = [s ++ show i | i <- [1..n]] ----fInstance m ("Cn",_) = "" --- fInstance _ _ m (cat,[]) = "" fInstance gId lexical m (cat,rules) = " fg t =" ++++ - (if isList + (if isList then " " ++ gId cat ++ " (fgs t) where\n fgs t = case unApp t of" else " case unApp t of") ++++ unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++ @@ -249,27 +266,28 @@ fInstance gId lexical m (cat,rules) = " Just (i," ++ "[" ++ prTList "," xx' ++ "])" +++ "| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx' - where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]] - mkRHS f vars - | isList = - if "Base" `isPrefixOf` f - then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]" - else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1) - | otherwise = - gId f +++ - prTList " " [prParenth ("fg" +++ x) | x <- vars] + where + xx' = ["x" ++ show i | (_,i) <- zip xx [1..]] + mkRHS f vars + | isList = + if "Base" `isPrefixOf` f + then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]" + else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1) + | otherwise = + gId f +++ + prTList " " [prParenth ("fg" +++ x) | x <- vars] --type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] hSkeleton :: PGF -> (String,HSkeleton) -hSkeleton gr = - (showCId (absname gr), - let fs = - [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) | +hSkeleton gr = + (showCId (absname gr), + let fs = + [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) | fs@((_, (_,c)):_) <- fns] - in fs ++ [(sc, []) | c <- cts, let sc = showCId c, notElem sc (["Int", "Float", "String"] ++ map fst fs)] + in fs ++ [(sc, []) | c <- cts, let sc = showCId c, sc `notElem` (["Int", "Float", "String"] ++ map fst fs)] ) where - cts = Map.keys (cats (abstract gr)) + cts = Map.keys (cats (abstract gr)) fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr))))) valtyps (_, (_,x)) (_, (_,y)) = compare x y valtypg (_, (_,x)) (_, (_,y)) = x == y @@ -283,9 +301,10 @@ updateSkeleton cat skel rule = -} isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2 - && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs - where c = elemCat cat - fs = map fst rules + && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs + where + c = elemCat cat + fs = map fst rules -- | Gets the element category of a list category. elemCat :: OIdent -> OIdent @@ -302,7 +321,7 @@ baseSize (_,rules) = length bs where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules composClass :: [String] -composClass = +composClass = [ "", "class Compos t where", @@ -329,4 +348,3 @@ composClass = "", "newtype C b a = C { unC :: b }" ] - diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index c12fd862c..c7ea56b45 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -256,7 +256,7 @@ renamePattern :: Status -> Patt -> Check (Patt,[Ident]) renamePattern env patt = do r@(p',vs) <- renp patt let dupl = vs \\ nub vs - unless (null dupl) $ checkError (hang ("[C.4.13] Pattern is not linear:") 4 + unless (null dupl) $ checkError (hang ("[C.4.13] Pattern is not linear. All variable names on the left-hand side must be distinct.") 4 patt) return r where diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs index 8fd6023b3..b35aaf9ed 100644 --- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs +++ b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module GF.Compile.TypeCheck.ConcreteNew( checkLType, inferLType ) where -- The code here is based on the paper: @@ -19,6 +20,7 @@ import GF.Text.Pretty import Data.List (nub, (\\), tails) import qualified Data.IntMap as IntMap import Data.Maybe(fromMaybe,isNothing) +import qualified Control.Monad.Fail as Fail checkLType :: GlobalEnv -> Term -> Type -> Check (Term, Type) checkLType ge t ty = runTcM $ do @@ -646,8 +648,16 @@ instance Monad TcM where f >>= g = TcM (\ms msgs -> case unTcM f ms msgs of TcOk x ms msgs -> unTcM (g x) ms msgs TcFail msgs -> TcFail msgs) + +#if !(MIN_VERSION_base(4,13,0)) + -- Monad(fail) will be removed in GHC 8.8+ + fail = Fail.fail +#endif + +instance Fail.MonadFail TcM where fail = tcError . pp + instance Applicative TcM where pure = return (<*>) = ap diff --git a/src/compiler/GF/Compile/TypeCheck/RConcrete.hs b/src/compiler/GF/Compile/TypeCheck/RConcrete.hs index 134e71559..aa13d5406 100644 --- a/src/compiler/GF/Compile/TypeCheck/RConcrete.hs +++ b/src/compiler/GF/Compile/TypeCheck/RConcrete.hs @@ -127,8 +127,12 @@ inferLType gr g trm = case trm of ty <- if isWildIdent z then return val else substituteLType [(bt,z,a')] val - return (App f' a',ty) - _ -> checkError ("A function type is expected for" <+> ppTerm Unqualified 0 f <+> "instead of type" <+> ppType fty) + return (App f' a',ty) + _ -> + let term = ppTerm Unqualified 0 f + funName = pp . head . words .render $ term + in checkError ("A function type is expected for" <+> term <+> "instead of type" <+> ppType fty $$ + "\n ** Maybe you gave too many arguments to" <+> funName <+> "\n") S f x -> do (f', fty) <- inferLType gr g f @@ -220,8 +224,14 @@ inferLType gr g trm = case trm of return (RecType (zip ls ts'), typeType) ExtR r s -> do - (r',rT) <- inferLType gr g r + +--- over <- getOverload gr g Nothing r +--- let r1 = maybe r fst over + let r1 = r --- + + (r',rT) <- inferLType gr g r1 rT' <- computeLType gr g rT + (s',sT) <- inferLType gr g s sT' <- computeLType gr g sT @@ -327,7 +337,7 @@ getOverload gr g mt ot = case appForm ot of v <- matchOverload f typs ttys return $ Just v _ -> return Nothing - + where collectOverloads tr@(Q c) = case lookupOverload gr c of Ok typs -> typs @@ -395,7 +405,7 @@ getOverload gr g mt ot = case appForm ot of matchVal mt v = elem mt [Nothing,Just v,Just (unlocked v)] unlocked v = case v of - RecType fs -> RecType $ filter (not . isLockLabel . fst) fs + RecType fs -> RecType $ filter (not . isLockLabel . fst) (sortRec fs) _ -> v ---- TODO: accept subtypes ---- TODO: use a trie @@ -428,7 +438,9 @@ checkLType gr g trm typ0 = do else do b' <- checkIn (pp "abs") $ substituteLType [(bt',z,Vr x)] b checkLType gr ((bt,x,a):g) c b' return $ (Abs bt x c', Prod bt' z a b') - _ -> checkError $ "function type expected instead of" <+> ppType typ + _ -> checkError $ "function type expected instead of" <+> ppType typ $$ + "\n ** Double-check that the type signature of the operation" $$ + "matches the number of arguments given to it.\n" App f a -> do over <- getOverload gr g (Just typ) trm @@ -506,8 +518,13 @@ checkLType gr g trm typ0 = do RecType ss -> return $ map fst ss _ -> checkError ("cannot get labels from" $$ nest 2 (ppTerm Unqualified 0 typ2)) let ll1 = [l | (l,_) <- rr, notElem l ll2] - (r',_) <- checkLType gr g r (RecType [field | field@(l,_) <- rr, elem l ll1]) - (s',_) <- checkLType gr g s (RecType [field | field@(l,_) <- rr, elem l ll2]) + +--- over <- getOverload gr g Nothing r --- this would solve #66 but fail ParadigmsAra. AR 6/7/2020 +--- let r1 = maybe r fst over + let r1 = r --- + + (r',_) <- checkLType gr g r1 (RecType [field | field@(l,_) <- rr, elem l ll1]) + (s',_) <- checkLType gr g s (RecType [field | field@(l,_) <- rr, elem l ll2]) let rec = R ([(l,(Nothing,P r' l)) | l <- ll1] ++ [(l,(Nothing,P s' l)) | l <- ll2]) return (rec, typ) @@ -638,9 +655,31 @@ checkEqLType gr g t u trm = do (b,t',u',s) <- checkIfEqLType gr g t u trm case b of True -> return t' - False -> checkError $ s <+> "type of" <+> ppTerm Unqualified 0 trm $$ - "expected:" <+> ppTerm Qualified 0 t $$ -- ppqType t u $$ - "inferred:" <+> ppTerm Qualified 0 u -- ppqType u t + False -> + let inferredType = ppTerm Qualified 0 u + expectedType = ppTerm Qualified 0 t + term = ppTerm Unqualified 0 trm + funName = pp . head . words .render $ term + helpfulMsg = + case (arrows inferredType, arrows expectedType) of + (0,0) -> pp "" -- None of the types is a function + _ -> "\n **" <+> + if expectedType `isLessApplied` inferredType + then "Maybe you gave too few arguments to" <+> funName + else pp "Double-check that type signature and number of arguments match." + in checkError $ s <+> "type of" <+> term $$ + "expected:" <+> expectedType $$ -- ppqType t u $$ + "inferred:" <+> inferredType $$ -- ppqType u t + helpfulMsg + where + -- count the number of arrows in the prettyprinted term + arrows :: Doc -> Int + arrows = length . filter (=="->") . words . render + + -- If prettyprinted type t has fewer arrows then prettyprinted type u, + -- then t is "less applied", and we can print out more helpful error msg. + isLessApplied :: Doc -> Doc -> Bool + isLessApplied t u = arrows t < arrows u checkIfEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check (Bool,Type,Type,String) checkIfEqLType gr g t u trm = do diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs index 143a4f96f..4399405b8 100644 --- a/src/compiler/GF/Compile/Update.hs +++ b/src/compiler/GF/Compile/Update.hs @@ -27,9 +27,10 @@ import Data.List import qualified Data.Map as Map import Control.Monad import GF.Text.Pretty +import qualified Control.Monad.Fail as Fail -- | combine a list of definitions into a balanced binary search tree -buildAnyTree :: Monad m => ModuleName -> [(Ident,Info)] -> m (Map.Map Ident Info) +buildAnyTree :: Fail.MonadFail m => ModuleName -> [(Ident,Info)] -> m (Map.Map Ident Info) buildAnyTree m = go Map.empty where go map [] = return map diff --git a/src/compiler/GF/CompileInParallel.hs b/src/compiler/GF/CompileInParallel.hs index 68ac7aa4a..ed498a690 100644 --- a/src/compiler/GF/CompileInParallel.hs +++ b/src/compiler/GF/CompileInParallel.hs @@ -20,6 +20,8 @@ import GF.Infra.Ident(moduleNameS) import GF.Text.Pretty import GF.System.Console(TermColors(..),getTermColors) import qualified Data.ByteString.Lazy as BS +-- Control.Monad.Fail import will become redundant in GHC 8.8+ +import qualified Control.Monad.Fail as Fail -- | Compile the given grammar files and everything they depend on, -- like 'batchCompile'. This function compiles modules in parallel. @@ -256,6 +258,9 @@ instance Output m => Output (CollectOutput m) where putStrLnE s = CO (return (putStrLnE s,())) putStrE s = CO (return (putStrE s,())) +instance Fail.MonadFail m => Fail.MonadFail (CollectOutput m) where + fail = CO . fail + instance ErrorMonad m => ErrorMonad (CollectOutput m) where raise e = CO (raise e) handle (CO m) h = CO $ handle m (unCO . h) diff --git a/src/compiler/GF/CompileOne.hs b/src/compiler/GF/CompileOne.hs index e873d6119..48761671a 100644 --- a/src/compiler/GF/CompileOne.hs +++ b/src/compiler/GF/CompileOne.hs @@ -30,12 +30,13 @@ import qualified Data.Map as Map import GF.Text.Pretty(render,(<+>),($$)) --Doc, import GF.System.Console(TermColors(..),getTermColors) import Control.Monad((<=<)) +import qualified Control.Monad.Fail as Fail type OneOutput = (Maybe FullPath,CompiledModule) type CompiledModule = Module compileOne, reuseGFO, useTheSource :: - (Output m,ErrorMonad m,MonadIO m) => + (Output m,ErrorMonad m,MonadIO m, Fail.MonadFail m) => Options -> Grammar -> FullPath -> m OneOutput -- | Compile a given source file (or just load a .gfo file), diff --git a/src/compiler/GF/Data/BacktrackM.hs b/src/compiler/GF/Data/BacktrackM.hs index f5ae63997..14cbf90d2 100644 --- a/src/compiler/GF/Data/BacktrackM.hs +++ b/src/compiler/GF/Data/BacktrackM.hs @@ -13,6 +13,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE Rank2Types, MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE CPP #-} module GF.Data.BacktrackM ( -- * the backtracking state monad BacktrackM, @@ -32,6 +33,7 @@ import Data.List import Control.Applicative import Control.Monad import Control.Monad.State.Class +import qualified Control.Monad.Fail as Fail ---------------------------------------------------------------------- -- Combining endomorphisms and continuations @@ -69,6 +71,12 @@ instance Monad (BacktrackM s) where return a = BM (\c s b -> c a s b) BM m >>= k = BM (\c s b -> m (\a s b -> unBM (k a) c s b) s b) where unBM (BM m) = m + +#if !(MIN_VERSION_base(4,13,0)) + fail = Fail.fail +#endif + +instance Fail.MonadFail (BacktrackM s) where fail _ = mzero instance Functor (BacktrackM s) where diff --git a/src/compiler/GF/Data/ErrM.hs b/src/compiler/GF/Data/ErrM.hs index 033c1efac..288c61919 100644 --- a/src/compiler/GF/Data/ErrM.hs +++ b/src/compiler/GF/Data/ErrM.hs @@ -12,10 +12,12 @@ -- hack for BNFC generated files. AR 21/9/2003 ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} module GF.Data.ErrM where import Control.Monad (MonadPlus(..),ap) import Control.Applicative +import qualified Control.Monad.Fail as Fail -- | Like 'Maybe' type with error msgs data Err a = Ok a | Bad String @@ -33,10 +35,19 @@ fromErr a = err (const a) id instance Monad Err where return = Ok - fail = Bad Ok a >>= f = f a Bad s >>= f = Bad s +#if !(MIN_VERSION_base(4,13,0)) + -- Monad(fail) will be removed in GHC 8.8+ + fail = Fail.fail +#endif + +instance Fail.MonadFail Err where + fail = Bad + + + -- | added 2\/10\/2003 by PEB instance Functor Err where fmap f (Ok a) = Ok (f a) diff --git a/src/compiler/GF/Data/Operations.hs b/src/compiler/GF/Data/Operations.hs index 4daa9c5d8..08fa15c3e 100644 --- a/src/compiler/GF/Data/Operations.hs +++ b/src/compiler/GF/Data/Operations.hs @@ -53,6 +53,7 @@ import Control.Monad (liftM,liftM2) --,ap import GF.Data.ErrM import GF.Data.Relation +import qualified Control.Monad.Fail as Fail infixr 5 +++ infixr 5 ++- @@ -88,10 +89,10 @@ checkUnique ss = ["overloaded" +++ show s | s <- nub overloads] where overloaded s = length (filter (==s) ss) > 1 -- | this is what happens when matching two values in the same module -unifyMaybe :: (Eq a, Monad m) => Maybe a -> Maybe a -> m (Maybe a) +unifyMaybe :: (Eq a, Fail.MonadFail m) => Maybe a -> Maybe a -> m (Maybe a) unifyMaybe = unifyMaybeBy id -unifyMaybeBy :: (Eq b, Monad m) => (a->b) -> Maybe a -> Maybe a -> m (Maybe a) +unifyMaybeBy :: (Eq b, Fail.MonadFail m) => (a->b) -> Maybe a -> Maybe a -> m (Maybe a) unifyMaybeBy f (Just p1) (Just p2) | f p1==f p2 = return (Just p1) | otherwise = fail "" diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs index 4adff02f2..0df3236ff 100644 --- a/src/compiler/GF/Grammar/Canonical.hs +++ b/src/compiler/GF/Grammar/Canonical.hs @@ -265,7 +265,6 @@ instance PPA LinPattern where RecordPattern r -> block r TuplePattern ps -> "<"<>punctuate "," ps<>">" WildPattern -> pp "_" - _ -> parens p instance RhsSeparator LinPattern where rhsSep _ = pp "=" diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs index 8b3464674..0ec7f43e6 100644 --- a/src/compiler/GF/Grammar/CanonicalJSON.hs +++ b/src/compiler/GF/Grammar/CanonicalJSON.hs @@ -6,6 +6,7 @@ import Text.JSON import Control.Applicative ((<|>)) import Data.Ratio (denominator, numerator) import GF.Grammar.Canonical +import Control.Monad (guard) encodeJSON :: FilePath -> Grammar -> IO () @@ -126,10 +127,10 @@ instance JSON LinType where -- records are encoded as records: showJSON (RecordType rows) = showJSON rows - readJSON o = do "Str" <- readJSON o; return StrType - <|> do "Float" <- readJSON o; return FloatType - <|> do "Int" <- readJSON o; return IntType - <|> do ptype <- readJSON o; return (ParamType ptype) + readJSON o = StrType <$ parseString "Str" o + <|> FloatType <$ parseString "Float" o + <|> IntType <$ parseString "Int" o + <|> ParamType <$> readJSON o <|> TableType <$> o!".tblarg" <*> o!".tblval" <|> TupleType <$> o!".tuple" <|> RecordType <$> readJSON o @@ -186,7 +187,7 @@ instance JSON LinPattern where -- and records as records: showJSON (RecordPattern r) = showJSON r - readJSON o = do "_" <- readJSON o; return WildPattern + readJSON o = do p <- parseString "_" o; return WildPattern <|> do p <- readJSON o; return (ParamPattern (Param p [])) <|> ParamPattern <$> readJSON o <|> RecordPattern <$> readJSON o @@ -237,7 +238,7 @@ instance JSON VarId where showJSON Anonymous = showJSON "_" showJSON (VarId x) = showJSON x - readJSON o = do "_" <- readJSON o; return Anonymous + readJSON o = do parseString "_" o; return Anonymous <|> VarId <$> readJSON o instance JSON QualId where @@ -268,6 +269,9 @@ instance JSON FlagValue where -------------------------------------------------------------------------------- -- ** Convenience functions +parseString :: String -> JSValue -> Result () +parseString s o = guard . (== s) =<< readJSON o + (!) :: JSON a => JSValue -> String -> Result a obj ! key = maybe (fail $ "CanonicalJSON.(!): Could not find key: " ++ show key) readJSON diff --git a/src/compiler/GF/Grammar/Lexer.x b/src/compiler/GF/Grammar/Lexer.x index d1550dd09..bde0aa064 100644 --- a/src/compiler/GF/Grammar/Lexer.x +++ b/src/compiler/GF/Grammar/Lexer.x @@ -1,5 +1,6 @@ -- -*- haskell -*- { +{-# LANGUAGE CPP #-} module GF.Grammar.Lexer ( Token(..), Posn(..) , P, runP, runPartial, token, lexer, getPosn, failLoc @@ -18,6 +19,7 @@ import qualified Data.Map as Map import Data.Word(Word8) import Data.Char(readLitChar) --import Debug.Trace(trace) +import qualified Control.Monad.Fail as Fail } @@ -33,7 +35,7 @@ $u = [.\n] -- universal: any character :- "--" [.]* ; -- Toss single line comments -"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ; +"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ; $white+ ; @rsyms { tok ident } @@ -136,7 +138,7 @@ data Token res = eitherResIdent eitherResIdent :: (Ident -> Token) -> Ident -> Token -eitherResIdent tv s = +eitherResIdent tv s = case Map.lookup s resWords of Just t -> t Nothing -> tv s @@ -282,8 +284,16 @@ instance Monad P where (P m) >>= k = P $ \ s -> case m s of POk s a -> unP (k a) s PFailed posn err -> PFailed posn err + +#if !(MIN_VERSION_base(4,13,0)) + -- Monad(fail) will be removed in GHC 8.8+ + fail = Fail.fail +#endif + +instance Fail.MonadFail P where fail msg = P $ \(_,AI posn _ _) -> PFailed posn msg + runP :: P a -> BS.ByteString -> Either (Posn,String) a runP p bs = snd <$> runP' p (Pn 1 0,bs) diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs index 4c92fae8c..b088fe49c 100644 --- a/src/compiler/GF/Grammar/Macros.hs +++ b/src/compiler/GF/Grammar/Macros.hs @@ -32,6 +32,7 @@ import Control.Monad (liftM, liftM2, liftM3) import Data.List (sortBy,nub) import Data.Monoid import GF.Text.Pretty(render,(<+>),hsep,fsep) +import qualified Control.Monad.Fail as Fail -- ** Functions for constructing and analysing source code terms. @@ -237,7 +238,7 @@ isPredefConstant t = case t of Q (mod,_) | mod == cPredef || mod == cPredefAbs -> True _ -> False -checkPredefError :: Monad m => Term -> m Term +checkPredefError :: Fail.MonadFail m => Term -> m Term checkPredefError t = case t of Error s -> fail ("Error: "++s) diff --git a/src/compiler/GF/Infra/CheckM.hs b/src/compiler/GF/Infra/CheckM.hs index c5f9ba255..c0234999a 100644 --- a/src/compiler/GF/Infra/CheckM.hs +++ b/src/compiler/GF/Infra/CheckM.hs @@ -32,6 +32,7 @@ import System.FilePath(makeRelative) import Control.Parallel.Strategies(parList,rseq,using) import Control.Monad(liftM,ap) import Control.Applicative(Applicative(..)) +import qualified Control.Monad.Fail as Fail type Message = Doc type Error = Message @@ -53,6 +54,9 @@ instance Monad Check where (ws,Success x) -> unCheck (g x) {-ctxt-} ws (ws,Fail msg) -> (ws,Fail msg) +instance Fail.MonadFail Check where + fail = raise + instance Applicative Check where pure = return (<*>) = ap diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index 7455c83c4..2a2ffd176 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -2,13 +2,13 @@ module GF.Infra.Option ( -- ** Command line options -- *** Option types - Options, - Flags(..), - Mode(..), Phase(..), Verbosity(..), - OutputFormat(..), + Options, + Flags(..), + Mode(..), Phase(..), Verbosity(..), + OutputFormat(..), SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..), Dump(..), Pass(..), Recomp(..), - outputFormatsExpl, + outputFormatsExpl, -- *** Option parsing parseOptions, parseModuleOptions, fixRelativeLibPaths, -- *** Option pretty-printing @@ -44,9 +44,10 @@ import Data.Set (Set) import qualified Data.Set as Set import PGF.Internal(Literal(..)) +import qualified Control.Monad.Fail as Fail usageHeader :: String -usageHeader = unlines +usageHeader = unlines ["Usage: gf [OPTIONS] [FILE [...]]", "", "How each FILE is handled depends on the file name suffix:", @@ -89,10 +90,10 @@ data Phase = Preproc | Convert | Compile | Link data OutputFormat = FmtPGFPretty | FmtCanonicalGF | FmtCanonicalJson - | FmtJavaScript + | FmtJavaScript | FmtJSON - | FmtPython - | FmtHaskell + | FmtPython + | FmtHaskell | FmtJava | FmtProlog | FmtBNF @@ -101,37 +102,42 @@ data OutputFormat = FmtPGFPretty | FmtNoLR | FmtSRGS_XML | FmtSRGS_XML_NonRec - | FmtSRGS_ABNF + | FmtSRGS_ABNF | FmtSRGS_ABNF_NonRec - | FmtJSGF - | FmtGSL + | FmtJSGF + | FmtGSL | FmtVoiceXML | FmtSLF | FmtRegExp | FmtFA deriving (Eq,Ord) -data SISRFormat = +data SISRFormat = -- | SISR Working draft 1 April 2003 -- <http://www.w3.org/TR/2003/WD-semantic-interpretation-20030401/> - SISR_WD20030401 + SISR_WD20030401 | SISR_1_0 deriving (Show,Eq,Ord) data Optimization = OptStem | OptCSE | OptExpand | OptParametrize deriving (Show,Eq,Ord) -data CFGTransform = CFGNoLR +data CFGTransform = CFGNoLR | CFGRegular - | CFGTopDownFilter - | CFGBottomUpFilter + | CFGTopDownFilter + | CFGBottomUpFilter | CFGStartCatOnly | CFGMergeIdentical | CFGRemoveCycles deriving (Show,Eq,Ord) -data HaskellOption = HaskellNoPrefix | HaskellGADT | HaskellLexical - | HaskellConcrete | HaskellVariants +data HaskellOption = HaskellNoPrefix + | HaskellGADT + | HaskellLexical + | HaskellConcrete + | HaskellVariants + | HaskellData + | HaskellPGF2 deriving (Show,Eq,Ord) data Warning = WarnMissingLincat @@ -195,7 +201,7 @@ instance Show Options where parseOptions :: ErrorMonad err => [String] -- ^ list of string arguments -> err (Options, [FilePath]) -parseOptions args +parseOptions args | not (null errs) = errors errs | otherwise = do opts <- concatOptions `fmap` liftErr (sequence optss) return (opts, files) @@ -207,7 +213,7 @@ parseModuleOptions :: ErrorMonad err => -> err Options parseModuleOptions args = do (opts,nonopts) <- parseOptions args - if null nonopts + if null nonopts then return opts else errors $ map ("Non-option among module options: " ++) nonopts @@ -280,7 +286,7 @@ defaultFlags = Flags { optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize], optOptimizePGF = False, optSplitPGF = False, - optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter, + optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter, CFGTopDownFilter, CFGMergeIdentical], optLibraryPath = [], optStartCat = Nothing, @@ -300,7 +306,7 @@ defaultFlags = Flags { -- | Option descriptions {-# NOINLINE optDescr #-} optDescr :: [OptDescr (Err Options)] -optDescr = +optDescr = [ Option ['?','h'] ["help"] (NoArg (mode ModeHelp)) "Show help message.", Option ['V'] ["version"] (NoArg (mode ModeVersion)) "Display GF version number.", @@ -326,44 +332,44 @@ optDescr = -- Option ['t'] ["trace"] (NoArg (trace True)) "Trace computations", -- Option [] ["no-trace"] (NoArg (trace False)) "Don't trace computations", Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').", - Option ['f'] ["output-format"] (ReqArg outFmt "FMT") + Option ['f'] ["output-format"] (ReqArg outFmt "FMT") (unlines ["Output format. FMT can be one of:", "Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)", "Multiple concrete: pgf (default), json, js, pgf_pretty, prolog, python, ...", -- gar, "Single concrete only: bnf, ebnf, fa, gsl, jsgf, regexp, slf, srgs_xml, srgs_abnf, vxml, ....", -- cf, lbnf, "Abstract only: haskell, ..."]), -- prolog_abs, - Option [] ["sisr"] (ReqArg sisrFmt "FMT") + Option [] ["sisr"] (ReqArg sisrFmt "FMT") (unlines ["Include SISR tags in generated speech recognition grammars.", "FMT can be one of: old, 1.0"]), - Option [] ["haskell"] (ReqArg hsOption "OPTION") - ("Turn on an optional feature when generating Haskell data types. OPTION = " + Option [] ["haskell"] (ReqArg hsOption "OPTION") + ("Turn on an optional feature when generating Haskell data types. OPTION = " ++ concat (intersperse " | " (map fst haskellOptionNames))), - Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]") + Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]") "Treat CAT as a lexical category.", - Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]") + Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]") "Treat CAT as a literal category.", - Option ['D'] ["output-dir"] (ReqArg outDir "DIR") + Option ['D'] ["output-dir"] (ReqArg outDir "DIR") "Save output files (other than .gfo files) in DIR.", - Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR") + Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR") "Overrides the value of GF_LIB_PATH.", - Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp)) + Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp)) "Always recompile from source.", - Option [] ["gfo","recomp-if-newer"] (NoArg (recomp RecompIfNewer)) + Option [] ["recomp-if-newer"] (NoArg (recomp RecompIfNewer)) "(default) Recompile from source if the source is newer than the .gfo file.", - Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp)) + Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp)) "Never recompile from source, if there is already .gfo file.", Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.", Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from file.", - Option ['n'] ["name"] (ReqArg name "NAME") + Option ['n'] ["name"] (ReqArg name "NAME") (unlines ["Use NAME as the name of the output. This is used in the output file names, ", "with suffixes depending on the formats, and, when relevant, ", "internally in the output."]), Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.", Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.", - Option [] ["preproc"] (ReqArg preproc "CMD") + Option [] ["preproc"] (ReqArg preproc "CMD") (unlines ["Use CMD to preprocess input files.", "Multiple preprocessors can be used by giving this option multiple times."]), - Option [] ["coding"] (ReqArg coding "ENCODING") + Option [] ["coding"] (ReqArg coding "ENCODING") ("Character encoding of the source grammar, ENCODING = utf8, latin1, cp1251, ..."), Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.", Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.", @@ -371,7 +377,7 @@ optDescr = Option [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.", Option [] ["pmcfg"] (NoArg (pmcfg True)) "Generate PMCFG (default).", Option [] ["no-pmcfg"] (NoArg (pmcfg False)) "Don't generate PMCFG (useful for libraries).", - Option [] ["optimize"] (ReqArg optimize "OPT") + Option [] ["optimize"] (ReqArg optimize "OPT") "Select an optimization package. OPT = all | values | parametrize | none", Option [] ["optimize-pgf"] (NoArg (optimize_pgf True)) "Enable or disable global grammar optimization. This could significantly reduce the size of the final PGF file", @@ -446,7 +452,7 @@ optDescr = optimize x = case lookup x optimizationPackages of Just p -> set $ \o -> o { optOptimizations = p } Nothing -> fail $ "Unknown optimization package: " ++ x - + optimize_pgf x = set $ \o -> o { optOptimizePGF = x } splitPGF x = set $ \o -> o { optSplitPGF = x } @@ -470,7 +476,7 @@ outputFormats :: [(String,OutputFormat)] outputFormats = map fst outputFormatsExpl outputFormatsExpl :: [((String,OutputFormat),String)] -outputFormatsExpl = +outputFormatsExpl = [(("pgf_pretty", FmtPGFPretty),"human-readable pgf"), (("canonical_gf", FmtCanonicalGF),"Canonical GF source files"), (("canonical_json", FmtCanonicalJson),"Canonical JSON source files"), @@ -503,11 +509,11 @@ instance Read OutputFormat where readsPrec = lookupReadsPrec outputFormats optimizationPackages :: [(String, Set Optimization)] -optimizationPackages = +optimizationPackages = [("all", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]), ("values", Set.fromList [OptStem,OptCSE,OptExpand]), ("noexpand", Set.fromList [OptStem,OptCSE]), - + -- deprecated ("all_subs", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]), ("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]), @@ -515,7 +521,7 @@ optimizationPackages = ] cfgTransformNames :: [(String, CFGTransform)] -cfgTransformNames = +cfgTransformNames = [("nolr", CFGNoLR), ("regular", CFGRegular), ("topdown", CFGTopDownFilter), @@ -530,7 +536,9 @@ haskellOptionNames = ("gadt", HaskellGADT), ("lexical", HaskellLexical), ("concrete", HaskellConcrete), - ("variants", HaskellVariants)] + ("variants", HaskellVariants), + ("data", HaskellData), + ("pgf2", HaskellPGF2)] -- | This is for bacward compatibility. Since GHC 6.12 we -- started using the native Unicode support in GHC but it @@ -547,7 +555,7 @@ lookupShow xs z = fromMaybe "lookupShow" $ lookup z [(y,x) | (x,y) <- xs] lookupReadsPrec :: [(String,a)] -> Int -> ReadS a lookupReadsPrec xs _ s = [(z,rest) | (x,rest) <- lex s, (y,z) <- xs, y == x] -onOff :: Monad m => (Bool -> m a) -> Bool -> ArgDescr (m a) +onOff :: Fail.MonadFail m => (Bool -> m a) -> Bool -> ArgDescr (m a) onOff f def = OptArg g "[on,off]" where g ma = maybe (return def) readOnOff ma >>= f readOnOff x = case map toLower x of @@ -555,8 +563,8 @@ onOff f def = OptArg g "[on,off]" "off" -> return False _ -> fail $ "Expected [on,off], got: " ++ show x -readOutputFormat :: Monad m => String -> m OutputFormat -readOutputFormat s = +readOutputFormat :: Fail.MonadFail m => String -> m OutputFormat +readOutputFormat s = maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats -- FIXME: this is a copy of the function in GF.Devel.UseIO. @@ -568,7 +576,7 @@ splitInModuleSearchPath s = case break isPathSep s of isPathSep :: Char -> Bool isPathSep c = c == ':' || c == ';' --- +-- -- * Convenience functions for checking options -- @@ -590,7 +598,7 @@ isLiteralCat opts c = Set.member c (flag optLiteralCats opts) isLexicalCat :: Options -> String -> Bool isLexicalCat opts c = Set.member c (flag optLexicalCats opts) --- +-- -- * Convenience functions for setting options -- @@ -621,8 +629,8 @@ readMaybe s = case reads s of toEnumBounded :: (Bounded a, Enum a, Ord a) => Int -> Maybe a toEnumBounded i = let mi = minBound - ma = maxBound `asTypeOf` mi - in if i >= fromEnum mi && i <= fromEnum ma + ma = maxBound `asTypeOf` mi + in if i >= fromEnum mi && i <= fromEnum ma then Just (toEnum i `asTypeOf` mi) else Nothing diff --git a/src/compiler/GF/Infra/SIO.hs b/src/compiler/GF/Infra/SIO.hs index 75c57601b..906f39345 100644 --- a/src/compiler/GF/Infra/SIO.hs +++ b/src/compiler/GF/Infra/SIO.hs @@ -42,6 +42,7 @@ import qualified GF.Command.Importing as GF(importGrammar, importSource) #ifdef C_RUNTIME import qualified PGF2 #endif +import qualified Control.Monad.Fail as Fail -- * The SIO monad @@ -58,6 +59,9 @@ instance Monad SIO where return x = SIO (const (return x)) SIO m1 >>= xm2 = SIO $ \ h -> m1 h >>= \ x -> unS (xm2 x) h +instance Fail.MonadFail SIO where + fail = lift0 . fail + instance Output SIO where ePutStr = lift0 . ePutStr ePutStrLn = lift0 . ePutStrLn diff --git a/src/compiler/GF/Infra/UseIO.hs b/src/compiler/GF/Infra/UseIO.hs index e27b6e075..4c5a26d32 100644 --- a/src/compiler/GF/Infra/UseIO.hs +++ b/src/compiler/GF/Infra/UseIO.hs @@ -159,6 +159,9 @@ instance ErrorMonad IO where then h (ioeGetErrorString e) else ioError e {- +-- Control.Monad.Fail import will become redundant in GHC 8.8+ +import qualified Control.Monad.Fail as Fail + instance Functor IOE where fmap = liftM instance Applicative IOE where @@ -170,7 +173,15 @@ instance Monad IOE where IOE c >>= f = IOE $ do x <- c -- Err a appIOE $ err raise f x -- f :: a -> IOE a + + #if !(MIN_VERSION_base(4,13,0)) + fail = raise + #endif + +instance Fail.MonadFail IOE where fail = raise + + -} -- | Print the error message and return a default value if the IO operation 'fail's diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs index b68a1bc2f..9987b7c39 100644 --- a/src/compiler/GF/Interactive.hs +++ b/src/compiler/GF/Interactive.hs @@ -38,6 +38,9 @@ import GF.Server(server) #endif import GF.Command.Messages(welcome) +import GF.Infra.UseIO (Output) +-- Provides an orphan instance of MonadFail for StateT in ghc versions < 8 +import Control.Monad.Trans.Instances () -- | Run the GF Shell in quiet mode (@gf -run@). mainRunGFI :: Options -> [FilePath] -> IO () @@ -99,7 +102,7 @@ timeIt act = -- | Optionally show how much CPU time was used to run an IO action optionallyShowCPUTime :: (Monad m,MonadSIO m) => Options -> m a -> m a -optionallyShowCPUTime opts act +optionallyShowCPUTime opts act | not (verbAtLeast opts Normal) = act | otherwise = do (dt,r) <- timeIt act liftSIO $ putStrLnFlush $ show (dt `div` 1000000000) ++ " msec" @@ -363,7 +366,7 @@ wordCompletion gfenv (left,right) = do pgf = multigrammar gfenv cmdEnv = commandenv gfenv optLang opts = valCIdOpts "lang" (head (languages pgf)) opts - optType opts = + optType opts = let str = valStrOpts "cat" (showCId $ lookStartCat pgf) opts in case readType str of Just ty -> ty @@ -410,7 +413,7 @@ wc_type = cmd_name option x y (c :cs) | isIdent c = option x y cs | otherwise = cmd x cs - + optValue x y ('"':cs) = str x y cs optValue x y cs = cmd x cs @@ -428,7 +431,7 @@ wc_type = cmd_name where x1 = take (length x - length y - d) x x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1 - + cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of [x] -> Just x _ -> Nothing diff --git a/src/compiler/GF/Server.hs b/src/compiler/GF/Server.hs index c287e8001..2e8b8b056 100644 --- a/src/compiler/GF/Server.hs +++ b/src/compiler/GF/Server.hs @@ -6,7 +6,7 @@ import qualified Data.Map as M import Control.Applicative -- for GHC<7.10 import Control.Monad(when) import Control.Monad.State(StateT(..),get,gets,put) -import Control.Monad.Error(ErrorT(..),Error(..)) +import Control.Monad.Except(ExceptT(..),runExceptT) import System.Random(randomRIO) --import System.IO(stderr,hPutStrLn) import GF.System.Catch(try) @@ -108,9 +108,9 @@ handle_fcgi execute1 state0 stateM cache = -- * Request handler -- | Handler monad -type HM s a = StateT (Q,s) (ErrorT Response IO) a +type HM s a = StateT (Q,s) (ExceptT Response IO) a run :: HM s Response -> (Q,s) -> IO (s,Response) -run m s = either bad ok =<< runErrorT (runStateT m s) +run m s = either bad ok =<< runExceptT (runStateT m s) where bad resp = return (snd s,resp) ok (resp,(qs,state)) = return (state,resp) @@ -123,12 +123,12 @@ put_qs qs = do state <- get_state; put (qs,state) put_state state = do qs <- get_qs; put (qs,state) err :: Response -> HM s a -err e = StateT $ \ s -> ErrorT $ return $ Left e +err e = StateT $ \ s -> ExceptT $ return $ Left e hmbracket_ :: IO () -> IO () -> HM s a -> HM s a hmbracket_ pre post m = do s <- get - e <- liftIO $ bracket_ pre post $ runErrorT $ runStateT m s + e <- liftIO $ bracket_ pre post $ runExceptT $ runStateT m s case e of Left resp -> err resp Right (a,s) -> do put s;return a @@ -407,9 +407,6 @@ resp404 path = Response 404 [plain,xo] $ "Not found: "++path++"\n" resp500 msg = Response 500 [plain,xo] $ "Internal error: "++msg++"\n" resp501 msg = Response 501 [plain,xo] $ "Not implemented: "++msg++"\n" -instance Error Response where - noMsg = resp500 "no message" - strMsg = resp500 -- * Content types plain = ct "text/plain" "" diff --git a/src/compiler/SimpleEditor/JSON.hs b/src/compiler/SimpleEditor/JSON.hs index 8f607dc84..06586c5eb 100644 --- a/src/compiler/SimpleEditor/JSON.hs +++ b/src/compiler/SimpleEditor/JSON.hs @@ -9,14 +9,24 @@ instance JSON Grammar where showJSON (Grammar name extends abstract concretes) = makeObj ["basename".=name, "extends".=extends, "abstract".=abstract, "concretes".=concretes] + readJSON = error "Grammar.readJSON intentionally not defined" instance JSON Abstract where showJSON (Abstract startcat cats funs) = makeObj ["startcat".=startcat, "cats".=cats, "funs".=funs] + readJSON = error "Abstract.readJSON intentionally not defined" -instance JSON Fun where showJSON (Fun name typ) = signature name typ -instance JSON Param where showJSON (Param name rhs) = definition name rhs -instance JSON Oper where showJSON (Oper name rhs) = definition name rhs +instance JSON Fun where + showJSON (Fun name typ) = signature name typ + readJSON = error "Fun.readJSON intentionally not defined" + +instance JSON Param where + showJSON (Param name rhs) = definition name rhs + readJSON = error "Param.readJSON intentionally not defined" + +instance JSON Oper where + showJSON (Oper name rhs) = definition name rhs + readJSON = error "Oper.readJSON intentionally not defined" signature name typ = makeObj ["name".=name,"type".=typ] definition name rhs = makeObj ["name".=name,"rhs".=rhs] @@ -26,12 +36,15 @@ instance JSON Concrete where makeObj ["langcode".=langcode, "opens".=opens, "params".=params, "opers".=opers, "lincats".=lincats, "lins".=lins] + readJSON = error "Concrete.readJSON intentionally not defined" instance JSON Lincat where showJSON (Lincat cat lintype) = makeObj ["cat".=cat, "type".=lintype] + readJSON = error "Lincat.readJSON intentionally not defined" instance JSON Lin where showJSON (Lin fun args lin) = makeObj ["fun".=fun, "args".=args, "lin".=lin] + readJSON = error "Lin.readJSON intentionally not defined" infix 1 .= name .= v = (name,showJSON v) |