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
grammar2haskell :: Options
-> String
-> 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
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"]]
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"])
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 :: (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")]
| 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 :: (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]
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)
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
elemCat :: OIdent -> OIdent
elemCat :: String -> String
elemCat = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
4
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 }"
]