-- | A utility for converting a BNF grammar to a Hydra module

module Hydra.Tools.GrammarToModule where

import Hydra.Kernel
import Hydra.Dsl.Annotations
import Hydra.Dsl.Bootstrap as Bootstrap
import Hydra.Dsl.Types as Types
import Hydra.Dsl.Terms as Terms
import qualified Hydra.Grammar as G

import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Maybe as Y

import Hydra.Sources.Core


grammarToModule :: Namespace -> G.Grammar -> Maybe String -> Module
grammarToModule :: Namespace -> Grammar -> Maybe String -> Module
grammarToModule Namespace
ns (G.Grammar [Production]
prods) Maybe String
desc = Namespace
-> [Element] -> [Module] -> [Module] -> Maybe String -> Module
Module Namespace
ns [Element]
elements [Module
hydraCoreModule] [Module
hydraCoreModule] Maybe String
desc
  where
    elements :: [Element]
elements = (String, Type) -> Element
pairToElement ((String, Type) -> Element) -> [(String, Type)] -> [Element]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[(String, Type)]] -> [(String, Type)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat ((String -> Pattern -> [(String, Type)])
-> [String] -> [Pattern] -> [[(String, Type)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
L.zipWith (Bool -> String -> Pattern -> [(String, Type)]
makeElements Bool
False) (String -> String
capitalize (String -> String)
-> ((String, Pattern) -> String) -> (String, Pattern) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Pattern) -> String
forall a b. (a, b) -> a
fst ((String, Pattern) -> String) -> [(String, Pattern)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, Pattern)]
prodPairs) ((String, Pattern) -> Pattern
forall a b. (a, b) -> b
snd ((String, Pattern) -> Pattern) -> [(String, Pattern)] -> [Pattern]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, Pattern)]
prodPairs))
      where
        prodPairs :: [(String, Pattern)]
prodPairs = (\(G.Production (G.Symbol String
s) Pattern
pat) -> (String
s, Pattern
pat)) (Production -> (String, Pattern))
-> [Production] -> [(String, Pattern)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Production]
prods
        pairToElement :: (String, Type) -> Element
pairToElement (String
lname, Type
typ) = Name -> Type -> Element
Bootstrap.typeElement (String -> Name
toName String
lname) Type
typ

    toName :: String -> Name
toName String
local = QualifiedName -> Name
unqualifyName (QualifiedName -> Name) -> QualifiedName -> Name
forall a b. (a -> b) -> a -> b
$ Maybe Namespace -> String -> QualifiedName
QualifiedName (Namespace -> Maybe Namespace
forall a. a -> Maybe a
Just Namespace
ns) String
local

    findNames :: t Pattern -> [String]
findNames t Pattern
pats = [String] -> [String]
forall a. [a] -> [a]
L.reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ([String], Map String Integer) -> [String]
forall a b. (a, b) -> a
fst ((([String], Map String Integer)
 -> Pattern -> ([String], Map String Integer))
-> ([String], Map String Integer)
-> t Pattern
-> ([String], Map String Integer)
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl ([String], Map String Integer)
-> Pattern -> ([String], Map String Integer)
forall {a}.
(Num a, Show a) =>
([String], Map String a) -> Pattern -> ([String], Map String a)
nextName ([], Map String Integer
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
nnString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
names, String -> a -> Map String a -> Map String a
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 String -> Map String a -> Maybe a
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show (a
ia -> a -> a
forall a. Num a => a -> a -> a
+a
1), a
ia -> a -> a
forall a. Num a => a -> a -> a
+a
1)

        rawName :: Pattern -> String
rawName Pattern
pat = case Pattern
pat of
          Pattern
G.PatternNil -> String
"none"
          G.PatternIgnored Pattern
_ -> String
"ignored"
          G.PatternLabeled (G.LabeledPattern (G.Label String
l) Pattern
_) -> String
l
          G.PatternConstant (G.Constant String
c) -> String -> String
decapitalize (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
withCharacterAliases String
c
          G.PatternRegex Regex
_ -> String
"regex"
          G.PatternNonterminal (G.Symbol String
s) -> String -> String
decapitalize String
s
          G.PatternSequence [Pattern]
_ -> String
"sequence"
          G.PatternAlternatives [Pattern]
_ -> String
"alts"
          G.PatternOption Pattern
p -> String -> String
decapitalize (Pattern -> String
rawName Pattern
p)
          G.PatternStar Pattern
p -> String
"listOf" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
capitalize (Pattern -> String
rawName Pattern
p)
          G.PatternPlus Pattern
p -> String
"listOf" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
capitalize (Pattern -> String
rawName Pattern
p)

    isComplex :: Pattern -> Bool
isComplex Pattern
pat = case Pattern
pat of
      G.PatternLabeled (G.LabeledPattern Label
_ Pattern
p) -> Pattern -> Bool
isComplex Pattern
p
      G.PatternSequence [Pattern]
pats -> Bool -> [Pattern] -> Bool
isNontrivial Bool
True [Pattern]
pats
      G.PatternAlternatives [Pattern]
pats -> Bool -> [Pattern] -> Bool
isNontrivial Bool
False [Pattern]
pats
      Pattern
_ -> Bool
False

    isNontrivial :: Bool -> [Pattern] -> Bool
isNontrivial Bool
isRecord [Pattern]
pats = if [Pattern] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [Pattern]
minPats Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
        then case [Pattern] -> Pattern
forall a. HasCallStack => [a] -> a
L.head [Pattern]
minPats of
          G.PatternLabeled LabeledPattern
_ -> Bool
True
          Pattern
_ -> Bool
False
        else Bool
True
      where
        minPats :: [Pattern]
minPats = Bool -> [Pattern] -> [Pattern]
simplify Bool
isRecord [Pattern]
pats

    -- Remove trivial patterns from records
    simplify :: Bool -> [Pattern] -> [Pattern]
simplify Bool
isRecord [Pattern]
pats = if Bool
isRecord then (Pattern -> Bool) -> [Pattern] -> [Pattern]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (Bool -> Bool
not (Bool -> Bool) -> (Pattern -> Bool) -> Pattern -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> Bool
isConstant) [Pattern]
pats else [Pattern]
pats
      where
        isConstant :: Pattern -> Bool
isConstant Pattern
p = case Pattern
p of
          G.PatternConstant Constant
_ -> Bool
True
          Pattern
_ -> Bool
False

    makeElements :: Bool -> String -> Pattern -> [(String, Type)]
makeElements Bool
omitTrivial String
lname Pattern
pat = Pattern -> [(String, Type)]
forPat Pattern
pat
      where
        forPat :: Pattern -> [(String, Type)]
forPat Pattern
pat = case Pattern
pat of
          Pattern
G.PatternNil -> [(String, Type)]
trivial
          G.PatternIgnored Pattern
_ -> []
          G.PatternLabeled (G.LabeledPattern (G.Label String
l) Pattern
p) -> Pattern -> [(String, Type)]
forPat Pattern
p
          G.PatternConstant Constant
_ -> [(String, Type)]
trivial
          G.PatternRegex Regex
_ -> [(String
lname, Type
Types.string)]
          G.PatternNonterminal (G.Symbol String
other) -> [(String
lname, Name -> Type
TypeVariable (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
toName String
other)]
          G.PatternSequence [Pattern]
pats -> Bool -> ([FieldType] -> Type) -> [Pattern] -> [(String, Type)]
forRecordOrUnion Bool
True [FieldType] -> Type
Types.record [Pattern]
pats
          G.PatternAlternatives [Pattern]
pats -> Bool -> ([FieldType] -> Type) -> [Pattern] -> [(String, Type)]
forRecordOrUnion Bool
False [FieldType] -> Type
Types.union [Pattern]
pats
          G.PatternOption Pattern
p -> String -> (Type -> Type) -> Pattern -> [(String, Type)]
mod String
"Option" Type -> Type
Types.optional Pattern
p
          G.PatternStar Pattern
p -> String -> (Type -> Type) -> Pattern -> [(String, Type)]
mod String
"Elmt" Type -> Type
Types.list Pattern
p
          G.PatternPlus Pattern
p -> String -> (Type -> Type) -> Pattern -> [(String, Type)]
mod String
"Elmt" Type -> Type
nonemptyList Pattern
p

        trivial :: [(String, Type)]
trivial = if Bool
omitTrivial then [] else [(String
lname, Type
Types.unit)]

        forRecordOrUnion :: Bool -> ([FieldType] -> Type) -> [Pattern] -> [(String, Type)]
forRecordOrUnion Bool
isRecord [FieldType] -> Type
construct [Pattern]
pats = if Bool -> [Pattern] -> Bool
isNontrivial Bool
isRecord [Pattern]
pats
            then (String
lname, [FieldType] -> Type
construct [FieldType]
fields)(String, Type) -> [(String, Type)] -> [(String, Type)]
forall a. a -> [a] -> [a]
:[(String, Type)]
els
            -- Eliminate single-field record and union types, unless the field has a user-defined name
            else Pattern -> [(String, Type)]
forPat (Pattern -> [(String, Type)]) -> Pattern -> [(String, Type)]
forall a b. (a -> b) -> a -> b
$ [Pattern] -> Pattern
forall a. HasCallStack => [a] -> a
L.head [Pattern]
minPats
          where
            fieldPairs :: [(FieldType, [(String, Type)])]
fieldPairs = (String -> Pattern -> (FieldType, [(String, Type)]))
-> [String] -> [Pattern] -> [(FieldType, [(String, Type)])]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
L.zipWith String -> Pattern -> (FieldType, [(String, Type)])
toField ([Pattern] -> [String]
forall {t :: * -> *}. Foldable t => t Pattern -> [String]
findNames [Pattern]
minPats) [Pattern]
minPats
            fields :: [FieldType]
fields = (FieldType, [(String, Type)]) -> FieldType
forall a b. (a, b) -> a
fst ((FieldType, [(String, Type)]) -> FieldType)
-> [(FieldType, [(String, Type)])] -> [FieldType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(FieldType, [(String, Type)])]
fieldPairs
            els :: [(String, Type)]
els = [[(String, Type)]] -> [(String, Type)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat ((FieldType, [(String, Type)]) -> [(String, Type)]
forall a b. (a, b) -> b
snd ((FieldType, [(String, Type)]) -> [(String, Type)])
-> [(FieldType, [(String, Type)])] -> [[(String, Type)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(FieldType, [(String, Type)])]
fieldPairs)
            minPats :: [Pattern]
minPats = Bool -> [Pattern] -> [Pattern]
simplify Bool
isRecord [Pattern]
pats

        toField :: String -> Pattern -> (FieldType, [(String, Type)])
toField String
n Pattern
p = String
-> ([(String, Type)] -> (FieldType, [(String, Type)]))
-> Pattern
-> (FieldType, [(String, Type)])
forall {b}. String -> ([(String, Type)] -> b) -> Pattern -> b
descend String
n [(String, Type)] -> (FieldType, [(String, Type)])
forall {a}. [(a, Type)] -> (FieldType, [(a, Type)])
f2 Pattern
p
          where
            f2 :: [(a, Type)] -> (FieldType, [(a, Type)])
f2 ((a
lname, Type
typ):[(a, Type)]
rest) = (Name -> Type -> FieldType
FieldType (String -> Name
Name String
n) Type
typ, [(a, Type)]
rest)

        mod :: String -> (Type -> Type) -> Pattern -> [(String, Type)]
mod String
n Type -> Type
f Pattern
p = String
-> ([(String, Type)] -> [(String, Type)])
-> Pattern
-> [(String, Type)]
forall {b}. String -> ([(String, Type)] -> b) -> Pattern -> b
descend String
n [(String, Type)] -> [(String, Type)]
forall {a}. [(a, Type)] -> [(a, Type)]
f2 Pattern
p
          where
            f2 :: [(a, Type)] -> [(a, Type)]
f2 ((a
lname, Type
typ):[(a, Type)]
rest) = (a
lname, Type -> Type
f Type
typ)(a, Type) -> [(a, Type)] -> [(a, Type)]
forall a. a -> [a] -> [a]
:[(a, Type)]
rest

        descend :: String -> ([(String, Type)] -> b) -> Pattern -> b
descend String
n [(String, Type)] -> b
f Pattern
p = [(String, Type)] -> b
f ([(String, Type)] -> b) -> [(String, Type)] -> b
forall a b. (a -> b) -> a -> b
$ if Pattern -> Bool
isComplex Pattern
p
            then (String
lname, Name -> Type
TypeVariable (String -> Name
toName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ (String, Type) -> String
forall a b. (a, b) -> a
fst ((String, Type) -> String) -> (String, Type) -> String
forall a b. (a -> b) -> a -> b
$ [(String, Type)] -> (String, Type)
forall a. HasCallStack => [a] -> a
L.head [(String, Type)]
cpairs))(String, Type) -> [(String, Type)] -> [(String, Type)]
forall a. a -> [a] -> [a]
:[(String, Type)]
cpairs
            else if [(String, Type)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [(String, Type)]
cpairs
              then [(String
lname, Type
Types.unit)]
              else (String
lname, (String, Type) -> Type
forall a b. (a, b) -> b
snd ([(String, Type)] -> (String, Type)
forall a. HasCallStack => [a] -> a
L.head [(String, Type)]
cpairs))(String, Type) -> [(String, Type)] -> [(String, Type)]
forall a. a -> [a] -> [a]
:[(String, Type)] -> [(String, Type)]
forall a. HasCallStack => [a] -> [a]
L.tail [(String, Type)]
cpairs
          where
            cpairs :: [(String, Type)]
cpairs = Bool -> String -> Pattern -> [(String, Type)]
makeElements Bool
False (String -> String -> String
childName String
lname String
n) Pattern
p

    childName :: String -> String -> String
childName String
lname String
n = String
lname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
capitalize String
n