hydra-0.12.0: src/main/haskell/Hydra/Sources/Kernel/Terms/Grammars.hs
{-# LANGUAGE OverloadedStrings #-}
module Hydra.Sources.Kernel.Terms.Grammars where
-- Standard imports for term-level kernel modules
import Hydra.Kernel
import Hydra.Sources.Libraries
import qualified Hydra.Dsl.Accessors as Accessors
import qualified Hydra.Dsl.Ast as Ast
import qualified Hydra.Dsl.Coders as Coders
import qualified Hydra.Dsl.Compute as Compute
import qualified Hydra.Dsl.Core as Core
import qualified Hydra.Dsl.Grammar as Grammar
import qualified Hydra.Dsl.Graph as Graph
import qualified Hydra.Dsl.Json as Json
import qualified Hydra.Dsl.Lib.Chars as Chars
import qualified Hydra.Dsl.Lib.Equality as Equality
import qualified Hydra.Dsl.Lib.Flows as Flows
import qualified Hydra.Dsl.Lib.Lists as Lists
import qualified Hydra.Dsl.Lib.Literals as Literals
import qualified Hydra.Dsl.Lib.Logic as Logic
import qualified Hydra.Dsl.Lib.Maps as Maps
import qualified Hydra.Dsl.Lib.Math as Math
import qualified Hydra.Dsl.Lib.Optionals as Optionals
import Hydra.Dsl.Phantoms as Phantoms
import qualified Hydra.Dsl.Lib.Sets as Sets
import Hydra.Dsl.Lib.Strings as Strings
import qualified Hydra.Dsl.Mantle as Mantle
import qualified Hydra.Dsl.Module as Module
import qualified Hydra.Dsl.TTerms as TTerms
import qualified Hydra.Dsl.TTypes as TTypes
import qualified Hydra.Dsl.Terms as Terms
import qualified Hydra.Dsl.Topology as Topology
import qualified Hydra.Dsl.Types as Types
import qualified Hydra.Dsl.Typing as Typing
import Hydra.Sources.Kernel.Types.All
import Prelude hiding ((++))
import qualified Data.Int as I
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Maybe as Y
import qualified Hydra.Sources.Kernel.Terms.Annotations as Annotations
import qualified Hydra.Sources.Kernel.Terms.Constants as Constants
import qualified Hydra.Sources.Kernel.Terms.Formatting as Formatting
import qualified Hydra.Sources.Kernel.Terms.Names as Names
import Hydra.Grammar as G
module_ :: Module
module_ = Module (Namespace "hydra.grammars") elements
[Annotations.module_, Formatting.module_, Names.module_]
kernelTypesModules $
Just ("A utility for converting a BNF grammar to a Hydra module.")
where
elements = [
el childNameDef,
el findNamesDef,
el grammarToModuleDef,
el isComplexDef,
el isNontrivialDef,
el makeElementsDef,
el rawNameDef,
el simplifyDef,
el toNameDef,
el wrapTypeDef]
define :: String -> TTerm a -> TBinding a
define = definitionInModule module_
childNameDef :: TBinding (String -> String -> String)
childNameDef = define "childName" $
doc "Generate child name" $
lambda "lname" $ lambda "n" $
Strings.cat $ list [var "lname", string "_", ref Formatting.capitalizeDef @@ var "n"]
findNamesDef :: TBinding ([G.Pattern] -> [String])
findNamesDef = define "findNames" $
doc "Find unique names for patterns" $
lambda "pats" $ lets [
"nextName">: lambda "acc" $ lambda "pat" $ lets [
"names">: first $ var "acc",
"nameMap">: second $ var "acc",
"rn">: ref rawNameDef @@ var "pat",
"nameAndIndex">: Optionals.maybe
(pair (var "rn") (int32 1))
(lambda "i" $ pair (Strings.cat2 (var "rn") (Literals.showInt32 $ Math.add (var "i") (int32 1))) (Math.add (var "i") (int32 1)))
(Maps.lookup (var "rn") (var "nameMap")),
"nn">: first $ var "nameAndIndex",
"ni">: second $ var "nameAndIndex"]
$ pair
(Lists.cons (var "nn") (var "names"))
(Maps.insert (var "rn") (var "ni") (var "nameMap"))]
$ Lists.reverse $ first $ Lists.foldl (var "nextName") (pair (list []) Maps.empty) (var "pats")
grammarToModuleDef :: TBinding (Namespace -> G.Grammar -> Maybe String -> Module)
grammarToModuleDef = define "grammarToModule" $
doc "Convert a BNF grammar to a Hydra module" $
lambda "ns" $ lambda "grammar" $ lambda "desc" $ lets [
"prodPairs">: Lists.map
(lambda "prod" $ pair
(Grammar.unSymbol $ Grammar.productionSymbol $ var "prod")
(Grammar.productionPattern $ var "prod"))
(Grammar.unGrammar $ var "grammar"),
"capitalizedNames">: Lists.map (lambda "pair" $ ref Formatting.capitalizeDef @@ (first $ var "pair")) (var "prodPairs"),
"patterns">: Lists.map (lambda "pair" $ second $ var "pair") (var "prodPairs"),
"elementPairs">: Lists.concat $ Lists.zipWith
(ref makeElementsDef @@ false @@ var "ns")
(var "capitalizedNames")
(var "patterns"),
"elements">: Lists.map
(lambda "pair" $ lets [
"lname">: first $ var "pair",
"typ">: ref wrapTypeDef @@ (second $ var "pair")]
$ ref Annotations.typeElementDef @@ (ref toNameDef @@ var "ns" @@ var "lname") @@ var "typ")
(var "elementPairs")]
$ Module.module_ (var "ns") (var "elements") (list []) (list []) (var "desc")
isComplexDef :: TBinding (G.Pattern -> Bool)
isComplexDef = define "isComplex" $
doc "Check if pattern is complex" $
lambda "pat" $ match G._Pattern (Just false) [
_Pattern_labeled>>: lambda "lp" $ ref isComplexDef @@ (Grammar.labeledPatternPattern $ var "lp"),
_Pattern_sequence>>: lambda "pats" $ ref isNontrivialDef @@ true @@ var "pats",
_Pattern_alternatives>>: lambda "pats" $ ref isNontrivialDef @@ false @@ var "pats"]
@@ var "pat"
isNontrivialDef :: TBinding (Bool -> [G.Pattern] -> Bool)
isNontrivialDef = define "isNontrivial" $
doc "Check if patterns are nontrivial" $
lambda "isRecord" $ lambda "pats" $ lets [
"minPats">: ref simplifyDef @@ var "isRecord" @@ var "pats"]
$ Logic.ifElse (Equality.equal (Lists.length $ var "minPats") (int32 1))
(match G._Pattern (Just false) [
_Pattern_labeled>>: constant true] @@ Lists.head (var "minPats"))
true
makeElementsDef :: TBinding (Bool -> Namespace -> String -> G.Pattern -> [(String, Type)])
makeElementsDef = define "makeElements" $
doc "Create elements from pattern" $
lambda "omitTrivial" $ lambda "ns" $ lambda "lname" $ lambda "pat" $ lets [
"trivial">: Logic.ifElse (var "omitTrivial") (list []) (list [pair (var "lname") TTypes.unit]),
"forRecordOrUnion">: lambda "isRecord" $ lambda "construct" $ lambda "pats" $ lets [
"minPats">: ref simplifyDef @@ var "isRecord" @@ var "pats",
"fieldNames">: ref findNamesDef @@ var "minPats",
"toField">: lambda "n" $ lambda "p" $ var "descend" @@ var "n" @@
(lambda "pairs" $ pair (Core.fieldType (Core.name $ var "n") (second $ Lists.head $ var "pairs")) (Lists.tail $ var "pairs")) @@
var "p",
"fieldPairs">: Lists.zipWith (var "toField") (var "fieldNames") (var "minPats"),
"fields">: Lists.map (unaryFunction first) (var "fieldPairs"),
"els">: Lists.concat $ Lists.map (unaryFunction second) (var "fieldPairs")]
$ Logic.ifElse (ref isNontrivialDef @@ var "isRecord" @@ var "pats")
(Lists.cons (pair (var "lname") (var "construct" @@ var "fields")) (var "els"))
(var "forPat" @@ (Lists.head $ var "minPats")),
"mod">: lambda "n" $ lambda "f" $ lambda "p" $ var "descend" @@ var "n" @@
(lambda "pairs" $ Lists.cons (pair (var "lname") (var "f" @@ (second $ Lists.head $ var "pairs"))) (Lists.tail $ var "pairs")) @@
var "p",
"descend">: lambda "n" $ lambda "f" $ lambda "p" $ lets [
"cpairs">: ref makeElementsDef @@ false @@ var "ns" @@ (ref childNameDef @@ var "lname" @@ var "n") @@ var "p"]
$ var "f" @@ Logic.ifElse (ref isComplexDef @@ var "p")
(Lists.cons (pair (var "lname") (Core.typeVariable $ ref toNameDef @@ var "ns" @@ (first $ Lists.head $ var "cpairs"))) (var "cpairs"))
(Logic.ifElse (Lists.null $ var "cpairs")
(list [pair (var "lname") TTypes.unit])
(Lists.cons (pair (var "lname") (second $ Lists.head $ var "cpairs")) (Lists.tail $ var "cpairs"))),
"forPat">: lambda "pat" $ match G._Pattern Nothing [
_Pattern_alternatives>>: lambda "pats" $ var "forRecordOrUnion" @@ false @@
(lambda "fields" $ Core.typeUnion $ Core.rowType (ref Constants.placeholderNameDef) (var "fields")) @@ var "pats",
_Pattern_constant>>: constant $ var "trivial",
_Pattern_ignored>>: constant $ list [],
_Pattern_labeled>>: lambda "lp" $ var "forPat" @@ Grammar.labeledPatternPattern (var "lp"),
_Pattern_nil>>: constant $ var "trivial",
_Pattern_nonterminal>>: lambda "s" $ list [pair (var "lname") $ Core.typeVariable $
ref toNameDef @@ var "ns" @@ Grammar.unSymbol (var "s")],
_Pattern_option>>: lambda "p" $ var "mod" @@ string "Option" @@ (unaryFunction TTypes.optional) @@ var "p",
_Pattern_plus>>: lambda "p" $ var "mod" @@ string "Elmt" @@ (unaryFunction TTypes.list) @@ var "p",
_Pattern_regex>>: constant $ list [pair (var "lname") TTypes.string],
_Pattern_sequence>>: lambda "pats" $ var "forRecordOrUnion" @@ true @@
(lambda "fields" $ Core.typeRecord $ Core.rowType (ref Constants.placeholderNameDef) (var "fields")) @@ var "pats",
_Pattern_star>>: lambda "p" $ var "mod" @@ string "Elmt" @@ (unaryFunction TTypes.list) @@ var "p"]
@@ var "pat"]
$ var "forPat" @@ var "pat"
rawNameDef :: TBinding (G.Pattern -> String)
rawNameDef = define "rawName" $
doc "Get raw name from pattern" $
lambda "pat" $ match G._Pattern Nothing [
_Pattern_alternatives>>: constant $ string "alts",
_Pattern_constant>>: lambda "c" $ ref Formatting.capitalizeDef @@ (ref Formatting.withCharacterAliasesDef @@ (Grammar.unConstant $ var "c")),
_Pattern_ignored>>: constant $ string "ignored",
_Pattern_labeled>>: lambda "lp" $ Grammar.unLabel $ Grammar.labeledPatternLabel $ var "lp",
_Pattern_nil>>: constant $ string "none",
_Pattern_nonterminal>>: lambda "s" $ ref Formatting.capitalizeDef @@ (Grammar.unSymbol $ var "s"),
_Pattern_option>>: lambda "p" $ ref Formatting.capitalizeDef @@ (ref rawNameDef @@ var "p"),
_Pattern_plus>>: lambda "p" $ Strings.cat2 (string "listOf") (ref Formatting.capitalizeDef @@ (ref rawNameDef @@ var "p")),
_Pattern_regex>>: constant $ string "regex",
_Pattern_sequence>>: constant $ string "sequence",
_Pattern_star>>: lambda "p" $ Strings.cat2 (string "listOf") (ref Formatting.capitalizeDef @@ (ref rawNameDef @@ var "p"))]
@@ var "pat"
simplifyDef :: TBinding (Bool -> [G.Pattern] -> [G.Pattern])
simplifyDef = define "simplify" $
doc "Remove trivial patterns from records" $
lambda "isRecord" $ lambda "pats" $ lets [
"isConstant">: lambda "p" $ match G._Pattern (Just false) [
G._Pattern_constant>>: constant true] @@ var "p"]
$ Logic.ifElse (var "isRecord")
(Lists.filter (lambda "p" $ Logic.not $ var "isConstant" @@ var "p") (var "pats"))
(var "pats")
toNameDef :: TBinding (Namespace -> String -> Name)
toNameDef = define "toName" $
doc "Convert local name to qualified name" $
lambda "ns" $ lambda "local" $
ref Names.unqualifyNameDef @@ (Module.qualifiedName (just $ var "ns") (var "local"))
wrapTypeDef :: TBinding (Type -> Type)
wrapTypeDef = define "wrapType" $
doc "Wrap a type in a placeholder name, unless it is already a wrapper, record, or union type" $
lambda "t" $ cases _Type (var "t") (Just $ Core.typeWrap $ Core.wrappedType (Core.nameLift placeholderName) $ var "t") [
_Type_record>>: constant $ var "t",
_Type_union>>: constant $ var "t",
_Type_wrap>>: constant $ var "t"]