----------------------------------------------------------------------
-- |
-- Module      : PGFtoHaskell
-- 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.Compile.PGFtoHaskell (grammar2haskell) where

import PGF(showCId)
import PGF.Internal

import GF.Data.Operations
import GF.Infra.Option

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 :: Options -> String -> PGF -> String
grammar2haskell Options
opts String
name PGF
gr = (String -> String -> String) -> String -> [String] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> String -> String
(++++) [] ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
  [String]
pragmas [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Bool -> String -> String -> [String] -> [String]
haskPreamble Bool
gadt String
name String
derivingClause ([String]
extraImports [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
pgfImports) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  [String
types, (String -> String)
-> (String -> Bool) -> (String, HSkeleton) -> String
gfinstances String -> String
gId String -> Bool
lexical (String, HSkeleton)
gr'] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
compos
    where gr' :: (String, HSkeleton)
gr' = PGF -> (String, HSkeleton)
hSkeleton PGF
gr
          gadt :: Bool
gadt = Options -> HaskellOption -> Bool
haskellOption Options
opts HaskellOption
HaskellGADT
          dataExt :: Bool
dataExt = Options -> HaskellOption -> Bool
haskellOption Options
opts HaskellOption
HaskellData
          pgf2 :: Bool
pgf2 = Options -> HaskellOption -> Bool
haskellOption Options
opts HaskellOption
HaskellPGF2
          lexical :: String -> Bool
lexical String
cat = Options -> HaskellOption -> Bool
haskellOption Options
opts HaskellOption
HaskellLexical Bool -> Bool -> Bool
&& Options -> String -> Bool
isLexicalCat Options
opts String
cat
          gId :: String -> String
gId | Options -> HaskellOption -> Bool
haskellOption Options
opts HaskellOption
HaskellNoPrefix = String -> String
rmForbiddenChars
              | Bool
otherwise = (String
"G"String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
rmForbiddenChars
          -- GF grammars allow weird identifier names inside '', e.g. 'VP/Object'
          rmForbiddenChars :: String -> String
rmForbiddenChars = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
"'!#$%&*+./<=>?@\\^|-~")
          pragmas :: [String]
pragmas | Bool
gadt = [String
"{-# LANGUAGE GADTs, FlexibleInstances, KindSignatures, RankNTypes, TypeSynonymInstances #-}"]
                  | Bool
dataExt = [String
"{-# LANGUAGE DeriveDataTypeable #-}"]
                  | Bool
otherwise = []
          derivingClause :: String
derivingClause
                 | Bool
dataExt = String
"deriving (Show,Data)"
                 | Bool
otherwise = String
"deriving Show"
          extraImports :: [String]
extraImports | Bool
gadt = [String
"import Control.Monad.Identity", String
"import Data.Monoid"]
                       | Bool
dataExt = [String
"import Data.Data"]
                       | Bool
otherwise = []
          pgfImports :: [String]
pgfImports | Bool
pgf2 = [String
"import PGF2 hiding (Tree)", String
"", String
"showCId :: CId -> String", String
"showCId = id"]
                     | Bool
otherwise = [String
"import PGF hiding (Tree)"]
          types :: String
types | Bool
gadt = (String -> String)
-> (String -> Bool) -> (String, HSkeleton) -> String
datatypesGADT String -> String
gId String -> Bool
lexical (String, HSkeleton)
gr'
                | Bool
otherwise = (String -> String)
-> String -> (String -> Bool) -> (String, HSkeleton) -> String
datatypes String -> String
gId String
derivingClause String -> Bool
lexical (String, HSkeleton)
gr'
          compos :: [String]
compos | Bool
gadt = (String -> String)
-> (String -> Bool) -> (String, HSkeleton) -> [String]
prCompos String -> String
gId String -> Bool
lexical (String, HSkeleton)
gr' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
composClass
                 | Bool
otherwise = []

haskPreamble :: Bool -> String -> String -> [String] -> [String]
haskPreamble :: Bool -> String -> String -> [String] -> [String]
haskPreamble Bool
gadt String
name String
derivingClause [String]
imports =
 [
  String
"module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" where",
  String
""
 ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
imports [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [
  String
"",
  String
"----------------------------------------------------",
  String
"-- automatic translation from GF to Haskell",
  String
"----------------------------------------------------",
  String
"",
  String
"class Gf a where",
  String
"  gf :: a -> Expr",
  String
"  fg :: Expr -> a",
  String
"",
  Bool -> String -> String -> String -> String -> String -> String
predefInst Bool
gadt String
derivingClause String
"GString" String
"String"  String
"unStr"    String
"mkStr",
  String
"",
  Bool -> String -> String -> String -> String -> String -> String
predefInst Bool
gadt String
derivingClause String
"GInt"    String
"Int"     String
"unInt"    String
"mkInt",
  String
"",
  Bool -> String -> String -> String -> String -> String -> String
predefInst Bool
gadt String
derivingClause String
"GFloat"  String
"Double"  String
"unFloat"  String
"mkFloat",
  String
"",
  String
"----------------------------------------------------",
  String
"-- below this line machine-generated",
  String
"----------------------------------------------------",
  String
""
 ]

predefInst :: Bool -> String -> String -> String -> String -> String -> String
predefInst :: Bool -> String -> String -> String -> String -> String -> String
predefInst Bool
gadt String
derivingClause String
gtyp String
typ String
destr String
consr =
  (if Bool
gadt
    then []
    else String
"newtype" String -> String -> String
+++ String
gtyp String -> String -> String
+++ String
"=" String -> String -> String
+++ String
gtyp String -> String -> String
+++ String
typ String -> String -> String
+++ String
derivingClause String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n"
    )
  String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"instance Gf" String -> String -> String
+++ String
gtyp String -> String -> String
+++ String
"where" String -> String -> String
++++
  String
"  gf (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
gtyp String -> String -> String
+++ String
"x) =" String -> String -> String
+++ String
consr String -> String -> String
+++ String
"x" String -> String -> String
++++
  String
"  fg t =" String -> String -> String
++++
  String
"    case "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
destrString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" t of" String -> String -> String
++++
  String
"      Just x  -> " String -> String -> String
+++ String
gtyp String -> String -> String
+++ String
"x" String -> String -> String
++++
  String
"      Nothing -> error (\"no" String -> String -> String
+++ String
gtyp String -> String -> String
+++ String
"\" ++ show t)"

type OIdent = String

type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]

datatypes :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (String,HSkeleton) -> String
datatypes :: (String -> String)
-> String -> (String -> Bool) -> (String, HSkeleton) -> String
datatypes String -> String
gId String
derivingClause String -> Bool
lexical = (String -> String -> String) -> String -> [String] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> String -> String
(+++++) String
"" ([String] -> String)
-> ((String, HSkeleton) -> [String])
-> (String, HSkeleton)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=String
"") ([String] -> [String])
-> ((String, HSkeleton) -> [String])
-> (String, HSkeleton)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, [(String, [String])]) -> String) -> HSkeleton -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String)
-> String
-> (String -> Bool)
-> (String, [(String, [String])])
-> String
hDatatype String -> String
gId String
derivingClause String -> Bool
lexical) (HSkeleton -> [String])
-> ((String, HSkeleton) -> HSkeleton)
-> (String, HSkeleton)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, HSkeleton) -> HSkeleton
forall a b. (a, b) -> b
snd

gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
gfinstances :: (String -> String)
-> (String -> Bool) -> (String, HSkeleton) -> String
gfinstances String -> String
gId String -> Bool
lexical (String
m,HSkeleton
g) = (String -> String -> String) -> String -> [String] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> String -> String
(+++++) String
"" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=String
"") ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ((String, [(String, [String])]) -> String) -> HSkeleton -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String)
-> (String -> Bool)
-> String
-> (String, [(String, [String])])
-> String
gfInstance String -> String
gId String -> Bool
lexical String
m) HSkeleton
g


hDatatype  :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
hDatatype :: (String -> String)
-> String
-> (String -> Bool)
-> (String, [(String, [String])])
-> String
hDatatype String -> String
_ String
_ String -> Bool
_ (String
"Cn",[(String, [String])]
_) = String
"" ---
hDatatype String -> String
gId String
_ String -> Bool
_ (String
cat,[]) = String
"data" String -> String -> String
+++ String -> String
gId String
cat
hDatatype String -> String
gId String
derivingClause String -> Bool
_ (String
cat,[(String, [String])]
rules) | (String, [(String, [String])]) -> Bool
isListCat (String
cat,[(String, [String])]
rules) =
 String
"newtype" String -> String -> String
+++ String -> String
gId String
cat String -> String -> String
+++ String
"=" String -> String -> String
+++ String -> String
gId String
cat String -> String -> String
+++ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
gId (String -> String
elemCat String
cat) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
  String -> String -> String
+++ String
derivingClause
hDatatype String -> String
gId String
derivingClause String -> Bool
lexical (String
cat,[(String, [String])]
rules) =
 String
"data" String -> String -> String
+++ String -> String
gId String
cat String -> String -> String
+++ String
"=" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 (if [(String, [String])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, [String])]
rules Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then String
"" else String
"\n  ") String -> String -> String
+++
 (String -> String -> String) -> [String] -> String
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\String
x String
y -> String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n |" String -> String -> String
+++ String
y) [String]
constructors String -> String -> String
++++
 String
" " String -> String -> String
+++ String
derivingClause
  where
    constructors :: [String]
constructors = [String -> String
gId String
f String -> String -> String
+++ (String -> String -> String) -> String -> [String] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> String -> String
(+++) String
"" ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
gId) [String]
xx) | (String
f,[String]
xx) <- Bool -> [(String, [String])] -> [(String, [String])]
nonLexicalRules (String -> Bool
lexical String
cat) [(String, [String])]
rules]
                   [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ if String -> Bool
lexical String
cat then [String -> String
lexicalConstructor String
cat String -> String -> String
+++ String
"String"] else []

nonLexicalRules :: Bool -> [(OIdent, [OIdent])] -> [(OIdent, [OIdent])]
nonLexicalRules :: Bool -> [(String, [String])] -> [(String, [String])]
nonLexicalRules Bool
False [(String, [String])]
rules = [(String, [String])]
rules
nonLexicalRules Bool
True [(String, [String])]
rules = [(String, [String])
r | r :: (String, [String])
r@(String
f,[String]
t) <- [(String, [String])]
rules, Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
t)]

lexicalConstructor :: OIdent -> String
lexicalConstructor :: String -> String
lexicalConstructor String
cat = String
"Lex" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cat

predefTypeSkel :: HSkeleton
predefTypeSkel :: HSkeleton
predefTypeSkel = [(String
c,[]) | String
c <- [String
"String", String
"Int", String
"Float"]]

-- GADT version of data types
datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
datatypesGADT :: (String -> String)
-> (String -> Bool) -> (String, HSkeleton) -> String
datatypesGADT String -> String
gId String -> Bool
lexical (String
_,HSkeleton
skel) = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    ((String, [(String, [String])]) -> [String])
-> HSkeleton -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> String) -> (String, [(String, [String])]) -> [String]
hCatTypeGADT String -> String
gId) (HSkeleton
skel HSkeleton -> HSkeleton -> HSkeleton
forall a. [a] -> [a] -> [a]
++ HSkeleton
predefTypeSkel) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    [
      String
"",
      String
"data Tree :: * -> * where"
    ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    ((String, [(String, [String])]) -> [String])
-> HSkeleton -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  "String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> ((String, [(String, [String])]) -> [String])
-> (String, [(String, [String])])
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String)
-> (String -> Bool) -> (String, [(String, [String])]) -> [String]
hDatatypeGADT String -> String
gId String -> Bool
lexical) HSkeleton
skel [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    [
      String
"  GString :: String -> Tree GString_",
      String
"  GInt :: Int -> Tree GInt_",
      String
"  GFloat :: Double -> Tree GFloat_",
      String
"",
      String
"instance Eq (Tree a) where",
      String
"  i == j = case (i,j) of"
    ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    ((String, [(String, [String])]) -> [String])
-> HSkeleton -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"    "String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> ((String, [(String, [String])]) -> [String])
-> (String, [(String, [String])])
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String)
-> (String -> Bool) -> (String, [(String, [String])]) -> [String]
hEqGADT String -> String
gId String -> Bool
lexical) HSkeleton
skel [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    [
      String
"    (GString x, GString y) -> x == y",
      String
"    (GInt x, GInt y) -> x == y",
      String
"    (GFloat x, GFloat y) -> x == y",
      String
"    _ -> False"
    ]

hCatTypeGADT :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> [String]
hCatTypeGADT :: (String -> String) -> (String, [(String, [String])]) -> [String]
hCatTypeGADT String -> String
gId (String
cat,[(String, [String])]
rules)
    = [String
"type"String -> String -> String
+++String -> String
gId String
catString -> String -> String
+++String
"="String -> String -> String
+++String
"Tree"String -> String -> String
+++String -> String
gId String
catString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"_",
       String
"data"String -> String -> String
+++String -> String
gId String
catString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"_"]

hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
hDatatypeGADT :: (String -> String)
-> (String -> Bool) -> (String, [(String, [String])]) -> [String]
hDatatypeGADT String -> String
gId String -> Bool
lexical (String
cat, [(String, [String])]
rules)
    | (String, [(String, [String])]) -> Bool
isListCat (String
cat,[(String, [String])]
rules) = [String -> String
gId String
catString -> String -> String
+++String
"::"String -> String -> String
+++String
"["String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
gId (String -> String
elemCat String
cat)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"]" String -> String -> String
+++ String
"->" String -> String -> String
+++ String
t]
    | Bool
otherwise =
        [ String -> String
gId String
f String -> String -> String
+++ String
"::" String -> String -> String
+++ (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
a -> String -> String
gId String
a String -> String -> String
+++ String
"-> ") [String]
args String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t
          | (String
f,[String]
args) <- Bool -> [(String, [String])] -> [(String, [String])]
nonLexicalRules (String -> Bool
lexical String
cat) [(String, [String])]
rules ]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ if String -> Bool
lexical String
cat then [String -> String
lexicalConstructor String
cat String -> String -> String
+++ String
":: String ->"String -> String -> String
+++ String
t] else []
  where t :: String
t = String
"Tree" String -> String -> String
+++ String -> String
gId String
cat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_"

hEqGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
hEqGADT :: (String -> String)
-> (String -> Bool) -> (String, [(String, [String])]) -> [String]
hEqGADT String -> String
gId String -> Bool
lexical (String
cat, [(String, [String])]
rules)
  | (String, [(String, [String])]) -> Bool
isListCat (String
cat,[(String, [String])]
rules) = let r :: (String, [String])
r = String -> (String, [String])
forall a. a -> (a, [String])
listr String
cat in [String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (String, [String]) -> String
forall (t :: * -> *) a.
Foldable t =>
String -> (String, t a) -> String
patt String
"x" (String, [String])
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (String, [String]) -> String
forall (t :: * -> *) a.
Foldable t =>
String -> (String, t a) -> String
patt String
"y" (String, [String])
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
listeqs]
  | Bool
otherwise = [String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (String, [String]) -> String
forall (t :: * -> *) a.
Foldable t =>
String -> (String, t a) -> String
patt String
"x" (String, [String])
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (String, [String]) -> String
forall (t :: * -> *) a.
Foldable t =>
String -> (String, t a) -> String
patt String
"y" (String, [String])
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String, [String]) -> String
forall (t :: * -> *) a a. Foldable t => (a, t a) -> String
eqs (String, [String])
r | (String, [String])
r <- Bool -> [(String, [String])] -> [(String, [String])]
nonLexicalRules (String -> Bool
lexical String
cat) [(String, [String])]
rules]
          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ if String -> Bool
lexical String
cat then [String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
lexicalConstructor String
cat String -> String -> String
+++ String
"x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
lexicalConstructor String
cat String -> String -> String
+++ String
"y" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") -> x == y"] else []

 where
   patt :: String -> (String, t a) -> String
patt String
s (String
f,t a
xs) = [String] -> String
unwords (String -> String
gId String
f String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> Int -> [String]
mkSVars String
s (t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
xs))
   eqs :: (a, t a) -> String
eqs (a
_,t a
xs) = [String] -> String
unwords (String
"and" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"[" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"," [String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" == " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
y |
     (String
x,String
y) <- [String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip (String -> Int -> [String]
mkSVars String
"x" (t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
xs)) (String -> Int -> [String]
mkSVars String
"y" (t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
xs)) ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"]"])
   listr :: a -> (a, [String])
listr a
c = (a
c,[String
"foo"]) -- foo just for length = 1
   listeqs :: String
listeqs = String
"and [x == y | (x,y) <- zip x1 y1]"

prCompos :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> [String]
prCompos :: (String -> String)
-> (String -> Bool) -> (String, HSkeleton) -> [String]
prCompos String -> String
gId String -> Bool
lexical (String
_,HSkeleton
catrules) =
    [String
"instance Compos Tree where",
     String
"  compos r a f t = case t of"]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    [String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. String -> [a] -> String
prComposCons (String -> String
gId String
f) [String]
xs | (String
c,[(String, [String])]
rs) <- HSkeleton
catrules, Bool -> Bool
not ((String, [(String, [String])]) -> Bool
isListCat (String
c,[(String, [String])]
rs)),
                                         (String
f,[String]
xs) <- [(String, [String])]
rs, Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
xs)]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    [String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. String -> [a] -> String
prComposCons (String -> String
gId String
c) [String
"x1"] | (String
c,[(String, [String])]
rs) <- HSkeleton
catrules, (String, [(String, [String])]) -> Bool
isListCat (String
c,[(String, [String])]
rs)]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    [String
"    _ -> r t"]
  where
    prComposCons :: String -> [a] -> String
prComposCons String
f [a]
xs = let vs :: [String]
vs = Int -> [String]
mkVars ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) in
                        String
f String -> String -> String
+++ [String] -> String
unwords [String]
vs String -> String -> String
+++ String
"->" String -> String -> String
+++ String -> [(String, a)] -> String
forall b. String -> [(String, b)] -> String
rhs String
f ([String] -> [a] -> [(String, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
vs [a]
xs)
    rhs :: String -> [(String, b)] -> String
rhs String
f [(String, b)]
vcs = String
"r" String -> String -> String
+++ String
f String -> String -> String
+++ [String] -> String
unwords (((String, b) -> String) -> [(String, b)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> (String, b) -> String
forall b. String -> (String, b) -> String
prRec String
f) [(String, b)]
vcs)
    prRec :: String -> (String, b) -> String
prRec String
f (String
v,b
c)
      | String -> Bool
isList String
f  = String
"`a` foldr (a . a (r (:)) . f) (r [])" String -> String -> String
+++ String
v
      | Bool
otherwise = String
"`a`" String -> String -> String
+++ String
"f" String -> String -> String
+++ String
v
    isList :: String -> Bool
isList String
f = String -> String
gId String
"List" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
f

gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String
gfInstance :: (String -> String)
-> (String -> Bool)
-> String
-> (String, [(String, [String])])
-> String
gfInstance String -> String
gId String -> Bool
lexical String
m (String, [(String, [String])])
crs = (String -> String)
-> (String -> Bool)
-> String
-> (String, [(String, [String])])
-> String
hInstance String -> String
gId String -> Bool
lexical String
m (String, [(String, [String])])
crs String -> String -> String
++++ (String -> String)
-> (String -> Bool)
-> String
-> (String, [(String, [String])])
-> String
forall p.
(String -> String)
-> (String -> Bool)
-> p
-> (String, [(String, [String])])
-> String
fInstance String -> String
gId String -> Bool
lexical String
m (String, [(String, [String])])
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 :: (String -> String)
-> (String -> Bool)
-> String
-> (String, [(String, [String])])
-> String
hInstance String -> String
gId String -> Bool
_ String
m (String
cat,[]) = [String] -> String
unlines [
  String
"instance Show" String -> String -> String
+++ String -> String
gId String
cat,
  String
"",
  String
"instance Gf" String -> String -> String
+++ String -> String
gId String
cat String -> String -> String
+++ String
"where",
  String
"  gf _ = undefined",
  String
"  fg _ = undefined"
  ]
hInstance String -> String
gId String -> Bool
lexical String
m (String
cat,[(String, [String])]
rules)
 | (String, [(String, [String])]) -> Bool
isListCat (String
cat,[(String, [String])]
rules) =
  String
"instance Gf" String -> String -> String
+++ String -> String
gId String
cat String -> String -> String
+++ String
"where" String -> String -> String
++++
     String
"  gf (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
gId String
cat String -> String -> String
+++ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
baseVars String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"])"
           String -> String -> String
+++ String
"=" String -> String -> String
+++ String -> [String] -> String
mkRHS (String
"Base"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
ec) [String]
baseVars String -> String -> String
++++
     String
"  gf (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
gId String
cat String -> String -> String
+++ String
"(x:xs)) = "
           String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
mkRHS (String
"Cons"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
ec) [String
"x",String -> String
prParenth (String -> String
gId String
catString -> String -> String
+++String
"xs")]
-- no show for GADTs
--     ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)"
 | Bool
otherwise =
  String
"instance Gf" String -> String -> String
+++ String -> String
gId String
cat String -> String -> String
+++ String
"where\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
  [String] -> String
unlines ([String -> [String] -> String
forall (t :: * -> *) a. Foldable t => String -> t a -> String
mkInst String
f [String]
xx | (String
f,[String]
xx) <- Bool -> [(String, [String])] -> [(String, [String])]
nonLexicalRules (String -> Bool
lexical String
cat) [(String, [String])]
rules]
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ if String -> Bool
lexical String
cat then [String
"  gf (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
lexicalConstructor String
cat String -> String -> String
+++ String
"x) = mkApp (mkCId x) []"] else [])
 where
   ec :: String
ec = String -> String
elemCat String
cat
   baseVars :: [String]
baseVars = Int -> [String]
mkVars ((String, [(String, [String])]) -> Int
baseSize (String
cat,[(String, [String])]
rules))
   mkInst :: String -> t a -> String
mkInst String
f t a
xx = let xx' :: [String]
xx' = Int -> [String]
mkVars (t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
xx) in String
"  gf " String -> String -> String
forall a. [a] -> [a] -> [a]
++
     (if t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
xx then String -> String
gId String
f else String -> String
prParenth (String -> String
gId String
f String -> String -> String
+++ (String -> String -> String) -> [String] -> String
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 String -> String -> String
(+++) [String]
xx')) String -> String -> String
+++
     String
"=" String -> String -> String
+++ String -> [String] -> String
mkRHS String
f [String]
xx'
   mkRHS :: String -> [String] -> String
mkRHS String
f [String]
vars = String
"mkApp (mkCId \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\")" String -> String -> String
+++
       String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
prTList String
", " [String
"gf" String -> String -> String
+++ String
x | String
x <- [String]
vars] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"

mkVars :: Int -> [String]
mkVars :: Int -> [String]
mkVars = String -> Int -> [String]
mkSVars String
"x"

mkSVars :: String -> Int -> [String]
mkSVars :: String -> Int -> [String]
mkSVars String
s Int
n = [String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i | Int
i <- [Int
1..Int
n]]

----fInstance m ("Cn",_) = "" ---
fInstance :: (String -> String)
-> (String -> Bool)
-> p
-> (String, [(String, [String])])
-> String
fInstance String -> String
_ String -> Bool
_ p
m (String
cat,[]) = String
""
fInstance String -> String
gId String -> Bool
lexical p
m (String
cat,[(String, [String])]
rules) =
  String
"  fg t =" String -> String -> String
++++
  (if Bool
isList
    then String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
gId String
cat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (fgs t) where\n     fgs t = case unApp t of"
    else String
"    case unApp t of") String -> String -> String
++++
  [String] -> String
unlines [String -> [String] -> String
forall a. String -> [a] -> String
mkInst String
f [String]
xx | (String
f,[String]
xx) <- Bool -> [(String, [String])] -> [(String, [String])]
nonLexicalRules (String -> Bool
lexical String
cat) [(String, [String])]
rules] String -> String -> String
++++
  (if String -> Bool
lexical String
cat then String
"      Just (i,[]) -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
lexicalConstructor String
cat String -> String -> String
+++ String
"(showCId i)" else String
"") String -> String -> String
++++
  String
"      _ -> error (\"no" String -> String -> String
+++ String
cat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" \" ++ show t)"
   where
    isList :: Bool
isList = (String, [(String, [String])]) -> Bool
isListCat (String
cat,[(String, [String])]
rules)
    mkInst :: String -> [a] -> String
mkInst String
f [a]
xx =
     String
"      Just (i," String -> String -> String
forall a. [a] -> [a] -> [a]
++
     String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
prTList String
"," [String]
xx' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"])" String -> String -> String
+++
     String
"| i == mkCId \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" ->" String -> String -> String
+++ String -> [String] -> String
mkRHS String
f [String]
xx'
       where
         xx' :: [String]
xx' = [String
"x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i | (a
_,Integer
i) <- [a] -> [Integer] -> [(a, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
xx [Integer
1..]]
         mkRHS :: String -> [String] -> String
mkRHS String
f [String]
vars
           | Bool
isList =
               if String
"Base" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
f
                             then String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
prTList String
", " [ String
"fg" String -> String -> String
+++ String
x | String
x <- [String]
vars ] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
                 else String
"fg" String -> String -> String
+++ ([String]
vars [String] -> Int -> String
forall a. [a] -> Int -> a
!! Int
0) String -> String -> String
+++ String
":" String -> String -> String
+++ String
"fgs" String -> String -> String
+++ ([String]
vars [String] -> Int -> String
forall a. [a] -> Int -> a
!! Int
1)
           | Bool
otherwise =
               String -> String
gId String
f String -> String -> String
+++
               String -> [String] -> String
prTList String
" " [String -> String
prParenth (String
"fg" String -> String -> String
+++ String
x) | String
x <- [String]
vars]

--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
hSkeleton :: PGF -> (String,HSkeleton)
hSkeleton :: PGF -> (String, HSkeleton)
hSkeleton PGF
gr =
  (CId -> String
showCId (PGF -> CId
absname PGF
gr),
   let fs :: HSkeleton
fs =
         [(CId -> String
showCId CId
c, [(CId -> String
showCId CId
f, (CId -> String) -> [CId] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map CId -> String
showCId [CId]
cs) | (CId
f, ([CId]
cs,CId
_)) <- [(CId, ([CId], CId))]
fs]) |
                                        fs :: [(CId, ([CId], CId))]
fs@((CId
_, ([CId]
_,CId
c)):[(CId, ([CId], CId))]
_) <- [[(CId, ([CId], CId))]]
fns]
   in HSkeleton
fs HSkeleton -> HSkeleton -> HSkeleton
forall a. [a] -> [a] -> [a]
++ [(String
sc, []) | CId
c <- [CId]
cts, let sc :: String
sc = CId -> String
showCId CId
c, String
sc String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ([String
"Int", String
"Float", String
"String"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((String, [(String, [String])]) -> String) -> HSkeleton -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, [(String, [String])]) -> String
forall a b. (a, b) -> a
fst HSkeleton
fs)]
  )
 where
   cts :: [CId]
cts = Map CId ([Hypo], [(Double, CId)], Double) -> [CId]
forall k a. Map k a -> [k]
Map.keys (Abstr -> Map CId ([Hypo], [(Double, CId)], Double)
cats (PGF -> Abstr
abstract PGF
gr))
   fns :: [[(CId, ([CId], CId))]]
fns = ((CId, ([CId], CId)) -> (CId, ([CId], CId)) -> Bool)
-> [(CId, ([CId], CId))] -> [[(CId, ([CId], CId))]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (CId, ([CId], CId)) -> (CId, ([CId], CId)) -> Bool
forall a a a a a. Eq a => (a, (a, a)) -> (a, (a, a)) -> Bool
valtypg (((CId, ([CId], CId)) -> (CId, ([CId], CId)) -> Ordering)
-> [(CId, ([CId], CId))] -> [(CId, ([CId], CId))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (CId, ([CId], CId)) -> (CId, ([CId], CId)) -> Ordering
forall a a a a a. Ord a => (a, (a, a)) -> (a, (a, a)) -> Ordering
valtyps (((CId, (Type, Int, Maybe ([Equation], [[Instr]]), Double))
 -> (CId, ([CId], CId)))
-> [(CId, (Type, Int, Maybe ([Equation], [[Instr]]), Double))]
-> [(CId, ([CId], CId))]
forall a b. (a -> b) -> [a] -> [b]
map (CId, (Type, Int, Maybe ([Equation], [[Instr]]), Double))
-> (CId, ([CId], CId))
forall a b c d. (a, (Type, b, c, d)) -> (a, ([CId], CId))
jty (Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> [(CId, (Type, Int, Maybe ([Equation], [[Instr]]), Double))]
forall k a. Map k a -> [(k, a)]
Map.assocs (Abstr -> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs (PGF -> Abstr
abstract PGF
gr)))))
   valtyps :: (a, (a, a)) -> (a, (a, a)) -> Ordering
valtyps (a
_, (a
_,a
x)) (a
_, (a
_,a
y)) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
x a
y
   valtypg :: (a, (a, a)) -> (a, (a, a)) -> Bool
valtypg (a
_, (a
_,a
x)) (a
_, (a
_,a
y)) = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y
   jty :: (a, (Type, b, c, d)) -> (a, ([CId], CId))
jty (a
f,(Type
ty,b
_,c
_,d
_)) = (a
f,Type -> ([CId], CId)
catSkeleton Type
ty)
{-
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
-}
isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool
isListCat :: (String, [(String, [String])]) -> Bool
isListCat (String
cat,[(String, [String])]
rules) = String
"List" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
cat Bool -> Bool -> Bool
&& [(String, [String])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, [String])]
rules Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
        Bool -> Bool -> Bool
&& (String
"Base"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
c) String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
fs Bool -> Bool -> Bool
&& (String
"Cons"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
c) String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
fs
    where
      c :: String
c = String -> String
elemCat String
cat
      fs :: [String]
fs = ((String, [String]) -> String) -> [(String, [String])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, [String]) -> String
forall a b. (a, b) -> a
fst [(String, [String])]
rules

-- | Gets the element category of a list category.
elemCat :: OIdent -> OIdent
elemCat :: String -> String
elemCat = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
4
{-
isBaseFun :: OIdent -> Bool
isBaseFun f = "Base" `isPrefixOf` f

isConsFun :: OIdent -> Bool
isConsFun f = "Cons" `isPrefixOf` f
-}
baseSize :: (OIdent, [(OIdent, [OIdent])]) -> Int
baseSize :: (String, [(String, [String])]) -> Int
baseSize (String
_,[(String, [String])]
rules) = [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
bs
    where Just (String
_,[String]
bs) = ((String, [String]) -> Bool)
-> [(String, [String])] -> Maybe (String, [String])
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String
"Base" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) (String -> Bool)
-> ((String, [String]) -> String) -> (String, [String]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, [String]) -> String
forall a b. (a, b) -> a
fst) [(String, [String])]
rules

composClass :: [String]
composClass :: [String]
composClass =
    [
     String
"",
     String
"class Compos t where",
     String
"  compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)",
     String
"         -> (forall a. t a -> m (t a)) -> t c -> m (t c)",
     String
"",
     String
"composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c",
     String
"composOp f = runIdentity . composOpM (Identity . f)",
     String
"",
     String
"composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c)",
     String
"composOpM = compos return ap",
     String
"",
     String
"composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m ()",
     String
"composOpM_ = composOpFold (return ()) (>>)",
     String
"",
     String
"composOpMonoid :: (Compos t, Monoid m) => (forall a. t a -> m) -> t c -> m",
     String
"composOpMonoid = composOpFold mempty mappend",
     String
"",
     String
"composOpMPlus :: (Compos t, MonadPlus m) => (forall a. t a -> m b) -> t c -> m b",
     String
"composOpMPlus = composOpFold mzero mplus",
     String
"",
     String
"composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b",
     String
"composOpFold z c f = unC . compos (\\_ -> C z) (\\(C x) (C y) -> C (c x y)) (C . f)",
     String
"",
     String
"newtype C b a = C { unC :: b }"
    ]