module Hydra.Util.GrammarToModule where

import Hydra.All
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