GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3

1 files changed, 271 insertions, 0 deletions

diff --git a/src-3.0/GF/API/GrammarToHaskell.hs b/src-3.0/GF/API/GrammarToHaskell.hs
new file mode 100644
index 000000000..c57cfed42
--- /dev/null
+++ b/src-3.0/GF/API/GrammarToHaskell.hs
@@ -0,0 +1,271 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GrammarToHaskell
+-- Maintainer  : Aarne Ranta
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/06/17 12:39:07 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.8 $
+--
+-- to write a GF abstract grammar into a Haskell module with translations from
+-- data objects into GF trees. Example: GSyntax for Agda.
+-- AR 11/11/1999 -- 7/12/2000 -- 18/5/2004
+-----------------------------------------------------------------------------
+
+module GF.API.GrammarToHaskell (grammar2haskell, grammar2haskellGADT) where
+
+import qualified GF.Canon.GFC as GFC
+import GF.Grammar.Macros
+
+import GF.Infra.Modules
+import GF.Data.Operations
+
+import Data.List (isPrefixOf, find, intersperse)
+import Data.Maybe (fromMaybe)
+
+-- | the main function
+grammar2haskell :: GFC.CanonGrammar -> String
+grammar2haskell gr = foldr (++++) [] $  
+  haskPreamble ++ [datatypes gr', gfinstances gr', fginstances gr']
+    where gr' = hSkeleton gr
+
+grammar2haskellGADT :: GFC.CanonGrammar -> String
+grammar2haskellGADT gr = foldr (++++) [] $  
+  ["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++ 
+  haskPreamble ++ [datatypesGADT gr', composInstance gr', showInstanceGADT gr', 
+                   gfinstances gr', fginstances gr']
+    where gr' = hSkeleton gr
+
+-- | by this you can prefix all identifiers with stg; the default is 'G'
+gId :: OIdent -> OIdent 
+gId i = 'G':i
+
+haskPreamble =
+ [
+  "module GSyntax where",
+  "",
+  "import GF.Infra.Ident",
+  "import GF.Grammar.Grammar",
+  "import GF.Grammar.PrGrammar",
+  "import GF.Grammar.Macros",
+  "import GF.Data.Compos",
+  "import GF.Data.Operations",
+  "",
+  "import Control.Applicative (pure,(<*>))",
+  "import Data.Traversable (traverse)",
+  "----------------------------------------------------",
+  "-- automatic translation from GF to Haskell",
+  "----------------------------------------------------",
+  "", 
+  "class Gf a where gf :: a -> Trm",
+  "class Fg a where fg :: Trm -> a",
+  "",
+  predefInst "GString" "String" "K s",
+  "",
+  predefInst "GInt" "Integer" "EInt s",
+  "",
+  predefInst "GFloat" "Double" "EFloat s",
+  "",
+  "----------------------------------------------------",
+  "-- below this line machine-generated",
+  "----------------------------------------------------",
+  ""
+ ]
+
+predefInst gtyp typ patt = 
+  "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++
+  "instance Gf" +++ gtyp +++ "where" ++++
+  "  gf (" ++ gtyp +++ "s) =" +++ patt +++++
+  "instance Fg" +++ gtyp +++ "where" ++++
+  "  fg t =" ++++
+  "    case termForm t of" ++++
+  "      Ok ([]," +++ patt +++ ",[]) ->" +++ gtyp +++ "s" ++++
+  "      _ -> error (\"no" +++ gtyp +++ "\" ++ prt t)"
+
+type OIdent = String
+
+type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
+
+datatypes, gfinstances, fginstances :: (String,HSkeleton) -> String
+datatypes   = (foldr (+++++) "") . (filter (/="")) . (map hDatatype) . snd
+gfinstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (hInstance m)) g
+fginstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (fInstance m)) g
+
+hDatatype :: (OIdent, [(OIdent, [OIdent])]) -> String
+hInstance, fInstance :: String -> (OIdent, [(OIdent, [OIdent])]) -> String
+
+hDatatype ("Cn",_) = "" ---
+hDatatype (cat,[]) = ""
+hDatatype (cat,rules) | isListCat (cat,rules) = 
+ "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]" 
+  +++ "deriving Show"
+hDatatype (cat,rules) =
+ "data" +++ gId cat +++ "=" ++
+ (if length rules == 1 then "" else "\n  ") +++
+ foldr1 (\x y -> x ++ "\n |" +++ y) 
+        [gId f +++ foldr (+++) "" (map gId xx) | (f,xx) <- rules] ++++
+ "  deriving Show"
+
+-- GADT version of data types
+datatypesGADT :: (String,HSkeleton) -> String
+datatypesGADT (_,skel) = 
+    unlines (concatMap hCatTypeGADT skel)
+    +++++
+    "data Tree :: * -> * where" ++++ unlines (concatMap (map ("  "++) . hDatatypeGADT) skel)
+
+hCatTypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String]
+hCatTypeGADT (cat,rules)
+    = ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_",
+       "data"+++gId cat++"_"]
+
+hDatatypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String]
+hDatatypeGADT (cat, rules) 
+    | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t]
+    | otherwise =
+        [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t | (f,args) <- rules ]
+  where t = "Tree" +++ gId cat ++ "_"
+
+
+----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
+hInstance m (cat,[]) = "" 
+hInstance m (cat,rules) 
+ | isListCat (cat,rules) =
+  "instance Gf" +++ gId cat +++ "where" ++++
+     " gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" 
+           +++ "=" +++ mkRHS ("Base"++ec) baseVars ++++
+     " 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)" 
+ | otherwise =
+  "instance Gf" +++ gId cat +++ "where" ++
+  (if length rules == 1 then "" else "\n") +++
+  foldr1 (\x y -> x ++ "\n" +++ y) [mkInst f xx | (f,xx) <- rules]
+ where
+   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')) +++
+     "=" +++ mkRHS f xx'
+   mkVars n = ["x" ++ show i | i <- [1..n]]
+   mkRHS f vars = "appqc \"" ++ m ++ "\" \"" ++ f ++ "\"" +++ 
+		   "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
+
+
+----fInstance m ("Cn",_) = "" ---
+fInstance m (cat,[]) = ""
+fInstance m (cat,rules) =
+  "instance Fg" +++ gId cat +++ "where" ++++
+  " fg t =" ++++
+  "  case termForm t of" ++++
+  foldr1 (\x y -> x ++ "\n" ++ y) [mkInst f xx | (f,xx) <- rules] ++++
+  "    _ -> error (\"no" +++ cat ++ " \" ++ prt t)"
+   where
+    mkInst f xx =
+     "    Ok ([], Q (IC \"" ++ m ++ "\") (IC \"" ++ f ++ "\")," ++
+     "[" ++ prTList "," xx' ++ "])" +++
+     "->" +++ mkRHS f xx'
+       where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
+	     mkRHS f vars 
+		 | isListCat (cat,rules) =
+		     if "Base" `isPrefixOf` f then
+			gId cat +++ "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
+		      else
+                       let (i,t) = (init vars,last vars)
+                        in "let" +++ gId cat +++ "xs = fg " ++ t +++ "in" +++ 
+                          gId cat +++ prParenth (prTList ":" (["fg"+++v | v <- i] ++ ["xs"]))
+		 | otherwise = 
+		     gId f +++  
+		     prTList " " [prParenth ("fg" +++ x) | x <- vars]
+
+composInstance :: (String,HSkeleton) -> String
+composInstance (_,skel) = unlines $
+    ["instance Compos Tree where",
+     "  compos f t = case t of"]
+    ++ map ("      "++) (concatMap prComposCat skel
+                         ++ if not allRecursive then ["_ -> pure t"] else [])
+    where
+    prComposCat c@(cat, fs) 
+        | isListCat c = [gId cat +++ "xs" +++ "->" 
+                         +++ "pure" +++ gId cat +++ "<*> traverse f" +++ "xs"]
+        | otherwise = concatMap (prComposFun cat) fs
+    prComposFun :: OIdent -> (OIdent,[OIdent]) -> [String]
+    prComposFun cat c@(fun,args) 
+	| any isTreeType args = [gId fun +++ unwords vars +++ "->" +++ rhs]
+        | otherwise = []
+      where vars = ["x" ++ show n | n <- [1..length args]]
+            rhs = "pure" +++ gId fun +++ unwords (zipWith prRec vars args)
+	        where prRec var typ
+                          | not (isTreeType typ) = "<*>" +++ "pure" +++ var
+			  | otherwise = "<*>" +++ "f" +++ var
+    allRecursive = and [any isTreeType args | (_,fs) <- skel, (_,args) <- fs] 
+    isTreeType cat = cat `elem` (map fst skel ++ builtin)
+    isList cat = case filter ((==cat) . fst) skel of
+                   [] -> error $ "Unknown cat " ++ show cat
+                   x:_ -> isListCat x
+    builtin = ["GString", "GInt", "GFloat"]
+
+showInstanceGADT :: (String,HSkeleton) -> String
+showInstanceGADT (_,skel) = unlines $
+            ["instance Show (Tree c) where",
+	     "  showsPrec n t = case t of"]
+	     ++ map ("    "++) (concatMap prShowCat skel)
+	     ++ ["   where opar n = if n > 0 then showChar '(' else id",
+	         "         cpar n = if n > 0 then showChar ')' else id"]
+  where 
+  prShowCat c@(cat, fs)
+      | isListCat c = [gId cat +++ "xs" +++ "->" +++ "showList" +++ "xs"]
+      | otherwise = map (prShowFun cat) fs
+  prShowFun :: OIdent -> (OIdent,[OIdent]) -> String
+  prShowFun cat (fun,args) 
+      | null vars = gId fun +++ "->" +++ "showString" +++ show fun
+      | otherwise = gId fun +++ unwords vars +++ "->" 
+			     +++ "opar n . showString" +++ show fun
+			     +++ unwords [". showChar ' ' . showsPrec 1 " ++ x | x <- vars]
+			     +++ ". cpar n"
+      where vars = ["x" ++ show n | n <- [1..length args]]
+
+hSkeleton :: GFC.CanonGrammar -> (String,HSkeleton)
+hSkeleton gr = (name,collectR rules [(c,[]) | c <- cats]) where
+  collectR rr hh =
+   case rr of
+     (fun,typ):rs -> case catSkeleton typ of
+        Ok (cats,cat) -> 
+             collectR rs (updateSkeleton (symid (snd cat)) hh (fun,
+	                                                    map (symid . snd) cats))
+        _ -> collectR rs hh
+     _ -> hh
+  cats =  [symid cat | (cat,GFC.AbsCat _ _) <- defs]
+  rules = [(symid fun, typ) | (fun,GFC.AbsFun typ _) <- defs]
+
+  defs = concat [tree2list (jments m) | im@(_,ModMod m) <- modules gr, isModAbs m]
+  name = ifNull "UnknownModule" (symid . last) [n | (n,ModMod m) <- modules gr, isModAbs m]
+
+updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
+updateSkeleton cat skel rule =
+ case skel of
+   (cat0,rules):rr | cat0 == cat -> (cat0, rule:rules) : rr
+   (cat0,rules):rr               -> (cat0, rules) : updateSkeleton cat rr rule
+   _ -> error $ cat ++ ": updating empty skeleton with" +++ show 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
+
+-- | Gets the element category of a list category.
+elemCat :: OIdent -> OIdent
+elemCat = drop 4
+
+isBaseFun :: OIdent -> Bool
+isBaseFun f = "Base" `isPrefixOf` f
+
+isConsFun :: OIdent -> Bool
+isConsFun f = "Cons" `isPrefixOf` f
+
+baseSize :: (OIdent, [(OIdent, [OIdent])]) -> Int
+baseSize (_,rules) = length bs
+    where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules