module Hydra.Util.GrammarToModule where
import Hydra.Kernel
import Hydra.Impl.Haskell.Dsl.Types as Types
import Hydra.Impl.Haskell.Dsl.Terms as Terms
import Hydra.Impl.Haskell.Dsl.Standard
import Hydra.CoreEncoding
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Maybe as Y
grammarToModule :: Namespace -> Grammar -> Maybe String -> Module Meta
grammarToModule :: Namespace -> Grammar -> Maybe String -> Module Meta
grammarToModule Namespace
ns (Grammar [Production]
prods) Maybe String
desc = forall m.
Namespace -> [Element m] -> [Module m] -> Maybe String -> Module m
Module Namespace
ns [Element Meta]
elements [] Maybe String
desc
where
elements :: [Element Meta]
elements = forall {m}. (String, Type m) -> Element m
pairToElement forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
L.zipWith (Bool -> String -> Pattern -> [(String, Type Meta)]
makeElements Bool
False) (String -> String
capitalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, Pattern)]
prodPairs) (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, Pattern)]
prodPairs))
where
prodPairs :: [(String, Pattern)]
prodPairs = (\(Production (Symbol String
s) Pattern
pat) -> (String
s, Pattern
pat)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Production]
prods
pairToElement :: (String, Type m) -> Element m
pairToElement (String
lname, Type m
typ) = forall m. Name -> Term m -> Term m -> Element m
Element (String -> Name
toName String
lname) (forall m. Name -> Term m
Terms.element Name
_Type) (forall m. Type m -> Term m
encodeType Type m
typ)
toName :: String -> Name
toName String
lname = Namespace -> String -> Name
fromQname Namespace
ns String
lname
findNames :: t Pattern -> [String]
findNames t Pattern
pats = forall a. [a] -> [a]
L.reverse forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl forall {a}.
(Num a, Show a) =>
([String], Map String a) -> Pattern -> ([String], Map String a)
nextName ([], forall k a. Map k a
M.empty) t Pattern
pats)
where
nextName :: ([String], Map String a) -> Pattern -> ([String], Map String a)
nextName ([String]
names, Map String a
nameMap) Pattern
pat = (String
nnforall a. a -> [a] -> [a]
:[String]
names, forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
rn a
ni Map String a
nameMap)
where
rn :: String
rn = Pattern -> String
rawName Pattern
pat
(String
nn, a
ni) = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
rn Map String a
nameMap of
Maybe a
Nothing -> (String
rn, a
1)
Just a
i -> (String
rn forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (a
iforall a. Num a => a -> a -> a
+a
1), a
iforall a. Num a => a -> a -> a
+a
1)
rawName :: Pattern -> String
rawName Pattern
pat = case Pattern
pat of
Pattern
PatternNil -> String
"none"
PatternIgnored Pattern
_ -> String
"ignored"
PatternLabeled (LabeledPattern (Label String
l) Pattern
_) -> String
l
PatternConstant (Constant String
c) -> String -> String
decapitalize forall a b. (a -> b) -> a -> b
$ String -> String
withCharacterAliases String
c
PatternRegex Regex
_ -> String
"regex"
PatternNonterminal (Symbol String
s) -> String -> String
decapitalize String
s
PatternSequence [Pattern]
_ -> String
"sequence"
PatternAlternatives [Pattern]
_ -> String
"alts"
PatternOption Pattern
p -> String -> String
decapitalize (Pattern -> String
rawName Pattern
p)
PatternStar Pattern
p -> String
"listOf" forall a. [a] -> [a] -> [a]
++ String -> String
capitalize (Pattern -> String
rawName Pattern
p)
PatternPlus Pattern
p -> String
"listOf" forall a. [a] -> [a] -> [a]
++ String -> String
capitalize (Pattern -> String
rawName Pattern
p)
isComplex :: Pattern -> Bool
isComplex Pattern
pat = case Pattern
pat of
PatternLabeled (LabeledPattern Label
_ Pattern
p) -> Pattern -> Bool
isComplex Pattern
p
PatternSequence [Pattern]
_ -> Bool
True
PatternAlternatives [Pattern]
_ -> Bool
True
Pattern
_ -> Bool
False
makeElements :: Bool -> String -> Pattern -> [(String, Type Meta)]
makeElements Bool
omitTrivial String
lname Pattern
pat = Pattern -> [(String, Type Meta)]
forPat Pattern
pat
where
forPat :: Pattern -> [(String, Type Meta)]
forPat Pattern
pat = case Pattern
pat of
Pattern
PatternNil -> forall {m}. [(String, Type m)]
trivial
PatternIgnored Pattern
_ -> []
PatternLabeled (LabeledPattern (Label String
_) Pattern
p) -> Pattern -> [(String, Type Meta)]
forPat Pattern
p
PatternConstant Constant
_ -> forall {m}. [(String, Type m)]
trivial
PatternRegex Regex
_ -> [(String
lname, forall m. Type m
Types.string)]
PatternNonterminal (Symbol String
other) -> [(String
lname, forall m. Name -> Type m
Types.nominal forall a b. (a -> b) -> a -> b
$ String -> Name
toName String
other)]
PatternSequence [Pattern]
pats -> Bool
-> ([FieldType Meta] -> Type Meta)
-> [Pattern]
-> [(String, Type Meta)]
forRecordOrUnion Bool
True forall m. [FieldType m] -> Type m
Types.record [Pattern]
pats
PatternAlternatives [Pattern]
pats -> Bool
-> ([FieldType Meta] -> Type Meta)
-> [Pattern]
-> [(String, Type Meta)]
forRecordOrUnion Bool
False forall m. [FieldType m] -> Type m
Types.union [Pattern]
pats
PatternOption Pattern
p -> String
-> (Type Meta -> Type Meta) -> Pattern -> [(String, Type Meta)]
mod String
"Option" forall m. Type m -> Type m
Types.optional Pattern
p
PatternStar Pattern
p -> String
-> (Type Meta -> Type Meta) -> Pattern -> [(String, Type Meta)]
mod String
"Elmt" forall m. Type m -> Type m
Types.list Pattern
p
PatternPlus Pattern
p -> String
-> (Type Meta -> Type Meta) -> Pattern -> [(String, Type Meta)]
mod String
"Elmt" Type Meta -> Type Meta
nonemptyList Pattern
p
trivial :: [(String, Type m)]
trivial = if Bool
omitTrivial then [] else [(String
lname, forall m. Type m
Types.unit)]
forRecordOrUnion :: Bool
-> ([FieldType Meta] -> Type Meta)
-> [Pattern]
-> [(String, Type Meta)]
forRecordOrUnion Bool
isRecord [FieldType Meta] -> Type Meta
c [Pattern]
pats = (String
lname, [FieldType Meta] -> Type Meta
c [FieldType Meta]
fields)forall a. a -> [a] -> [a]
:[(String, Type Meta)]
els
where
fieldPairs :: [(FieldType Meta, [(String, Type Meta)])]
fieldPairs = forall a. [Maybe a] -> [a]
Y.catMaybes forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
L.zipWith (Bool
-> String
-> Pattern
-> Maybe (FieldType Meta, [(String, Type Meta)])
toField Bool
isRecord) (forall {t :: * -> *}. Foldable t => t Pattern -> [String]
findNames [Pattern]
pats) [Pattern]
pats
fields :: [FieldType Meta]
fields = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(FieldType Meta, [(String, Type Meta)])]
fieldPairs
els :: [(String, Type Meta)]
els = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(FieldType Meta, [(String, Type Meta)])]
fieldPairs)
toField :: Bool
-> String
-> Pattern
-> Maybe (FieldType Meta, [(String, Type Meta)])
toField Bool
isRecord String
n Pattern
p = if Bool
ignore
then forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall {b}. String -> ([(String, Type Meta)] -> b) -> Pattern -> b
descend String
n forall {a} {m}. [(a, Type m)] -> (FieldType m, [(a, Type m)])
f2 Pattern
p
where
f2 :: [(a, Type m)] -> (FieldType m, [(a, Type m)])
f2 ((a
lname, Type m
typ):[(a, Type m)]
rest) = (forall m. FieldName -> Type m -> FieldType m
FieldType (String -> FieldName
FieldName String
n) Type m
typ, [(a, Type m)]
rest)
ignore :: Bool
ignore = if Bool
isRecord
then case Pattern
p of
PatternConstant Constant
_ -> Bool
True
Pattern
_ -> Bool
False
else Bool
False
mod :: String
-> (Type Meta -> Type Meta) -> Pattern -> [(String, Type Meta)]
mod String
n Type Meta -> Type Meta
f Pattern
p = forall {b}. String -> ([(String, Type Meta)] -> b) -> Pattern -> b
descend String
n forall {a}. [(a, Type Meta)] -> [(a, Type Meta)]
f2 Pattern
p
where
f2 :: [(a, Type Meta)] -> [(a, Type Meta)]
f2 ((a
lname, Type Meta
typ):[(a, Type Meta)]
rest) = (a
lname, Type Meta -> Type Meta
f Type Meta
typ)forall a. a -> [a] -> [a]
:[(a, Type Meta)]
rest
descend :: String -> ([(String, Type Meta)] -> b) -> Pattern -> b
descend String
n [(String, Type Meta)] -> b
f Pattern
p = [(String, Type Meta)] -> b
f forall a b. (a -> b) -> a -> b
$ if Pattern -> Bool
isComplex Pattern
p
then (String
lname, forall m. Name -> Type m
Types.nominal (String -> Name
toName forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
L.head [(String, Type Meta)]
cpairs))forall a. a -> [a] -> [a]
:[(String, Type Meta)]
cpairs
else if forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [(String, Type Meta)]
cpairs
then [(String
lname, forall m. Type m
Types.unit)]
else (String
lname, forall a b. (a, b) -> b
snd (forall a. [a] -> a
L.head [(String, Type Meta)]
cpairs))forall a. a -> [a] -> [a]
:forall a. [a] -> [a]
L.tail [(String, Type Meta)]
cpairs
where
cpairs :: [(String, Type Meta)]
cpairs = Bool -> String -> Pattern -> [(String, Type Meta)]
makeElements Bool
False (String -> String -> String
childName String
lname String
n) Pattern
p
childName :: String -> String -> String
childName String
lname String
n = String
lname forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ String -> String
capitalize String
n