From 5b401f3880f68828272dccfb3787cc3b3abd4cc3 Mon Sep 17 00:00:00 2001 From: Thomas Hallgren Date: Thu, 7 Mar 2019 17:41:16 +0100 Subject: Expose GF.Grammar.Canonical + some refactoring to make it available in other tools by depending on the gf package and importing it --- src/compiler/GF/Grammar/Canonical.hs | 62 +++++++++++++++++++++++++----------- 1 file changed, 44 insertions(+), 18 deletions(-) (limited to 'src/compiler/GF/Grammar/Canonical.hs') diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs index 0da72d634..ab9bf280c 100644 --- a/src/compiler/GF/Grammar/Canonical.hs +++ b/src/compiler/GF/Grammar/Canonical.hs @@ -1,7 +1,12 @@ --- | Abstract syntax for canonical GF grammars, i.e. what's left after +-- | +-- Module : GF.Grammar.Canonical +-- Stability : provisional +-- +-- Abstract syntax for canonical GF grammars, i.e. what's left after -- high-level constructions such as functors and opers have been eliminated -- by partial evaluation. This is intended as a common intermediate -- representation to simplify export to other formats. + module GF.Grammar.Canonical where import Prelude hiding ((<>)) import GF.Text.Pretty @@ -51,13 +56,11 @@ newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show) -- | Linearization value, RHS of @lin@ data LinValue = ConcatValue LinValue LinValue + | LiteralValue LinLiteral | ErrorValue String - | FloatConstant Float - | IntConstant Int | ParamConstant ParamValue | PredefValue PredefId | RecordValue [RecordRowValue] - | StrConstant String | TableValue LinType [TableRowValue] --- | VTableValue LinType [LinValue] | TupleValue [LinValue] @@ -66,7 +69,12 @@ data LinValue = ConcatValue LinValue LinValue | PreValue [([String], LinValue)] LinValue | Projection LinValue LabelId | Selection LinValue LinValue - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show) + +data LinLiteral = FloatConstant Float + | IntConstant Int + | StrConstant String + deriving (Eq,Ord,Show) data LinPattern = ParamPattern ParamPattern | RecordPattern [RecordRow LinPattern] @@ -87,27 +95,33 @@ data TableRowValue = TableRowValue LinPattern LinValue deriving (Eq,Ord,Show) -- *** Identifiers in Concrete Syntax -newtype PredefId = PredefId String deriving (Eq,Ord,Show) -newtype LabelId = LabelId String deriving (Eq,Ord,Show) -data VarValueId = VarValueId String deriving (Eq,Ord,Show) +newtype PredefId = PredefId Id deriving (Eq,Ord,Show) +newtype LabelId = LabelId Id deriving (Eq,Ord,Show) +data VarValueId = VarValueId QualId deriving (Eq,Ord,Show) -- | Name of param type or param value -newtype ParamId = ParamId String deriving (Eq,Ord,Show) +newtype ParamId = ParamId QualId deriving (Eq,Ord,Show) -------------------------------------------------------------------------------- -- ** Used in both Abstract and Concrete Syntax -newtype ModId = ModId String deriving (Eq,Show) +newtype ModId = ModId Id deriving (Eq,Ord,Show) -newtype CatId = CatId String deriving (Eq,Ord,Show) -newtype FunId = FunId String deriving (Eq,Show) +newtype CatId = CatId Id deriving (Eq,Ord,Show) +newtype FunId = FunId Id deriving (Eq,Show) -data VarId = Anonymous | VarId String deriving Show +data VarId = Anonymous | VarId Id deriving Show newtype Flags = Flags [(FlagName,FlagValue)] deriving Show -type FlagName = String +type FlagName = Id data FlagValue = Str String | Int Int | Flt Double deriving Show + +-- *** Identifiers + +type Id = String +data QualId = Qual ModId Id | Unqual Id deriving (Eq,Ord,Show) + -------------------------------------------------------------------------------- -- ** Pretty printing @@ -203,8 +217,7 @@ instance Pretty LinValue where instance PPA LinValue where ppA lv = case lv of - FloatConstant f -> pp f - IntConstant n -> pp n + LiteralValue l -> ppA l ParamConstant pv -> ppA pv PredefValue p -> ppA p RecordValue [] -> pp "<>" @@ -214,13 +227,20 @@ instance PPA LinValue where where alt (ss,lv) = hang (hcat (punctuate "|" (map doubleQuotes ss))) 2 ("=>"<+>lv) - StrConstant s -> doubleQuotes s -- hmm TableValue _ tvs -> "table"<+>block tvs -- VTableValue t ts -> "table"<+>t<+>brackets (semiSep ts) TupleValue lvs -> "<"<>punctuate "," lvs<>">" VarValue v -> pp v _ -> parens lv +instance Pretty LinLiteral where pp = ppA + +instance PPA LinLiteral where + ppA l = case l of + FloatConstant f -> pp f + IntConstant n -> pp n + StrConstant s -> doubleQuotes s -- hmm + instance RhsSeparator LinValue where rhsSep _ = pp "=" instance Pretty LinPattern where @@ -250,11 +270,17 @@ instance Pretty CatId where pp (CatId s) = pp s instance Pretty FunId where pp (FunId s) = pp s instance Pretty LabelId where pp (LabelId s) = pp s instance Pretty PredefId where pp = ppA -instance PPA PredefId where ppA (PredefId s) = pp s +instance PPA PredefId where ppA (PredefId s) = "Predef."<>s instance Pretty ParamId where pp = ppA instance PPA ParamId where ppA (ParamId s) = pp s instance Pretty VarValueId where pp (VarValueId s) = pp s +instance Pretty QualId where pp = ppA + +instance PPA QualId where + ppA (Qual m n) = m<>"_"<>n -- hmm + ppA (Unqual n) = pp n + instance Pretty Flags where pp (Flags []) = empty pp (Flags flags) = "flags" <+> vcat (map ppFlag flags) -- cgit v1.2.3 From 8e2424af49dfc8289fe938a36c5cdab96386c074 Mon Sep 17 00:00:00 2001 From: Thomas Hallgren Date: Tue, 12 Mar 2019 22:32:54 +0100 Subject: GF.Grammar.Canonical: add TuplePattern and CommentedValue --- src/compiler/GF/Grammar/Canonical.hs | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'src/compiler/GF/Grammar/Canonical.hs') diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs index ab9bf280c..8be659e1b 100644 --- a/src/compiler/GF/Grammar/Canonical.hs +++ b/src/compiler/GF/Grammar/Canonical.hs @@ -69,6 +69,7 @@ data LinValue = ConcatValue LinValue LinValue | PreValue [([String], LinValue)] LinValue | Projection LinValue LabelId | Selection LinValue LinValue + | CommentedValue String LinValue deriving (Eq,Ord,Show) data LinLiteral = FloatConstant Float @@ -78,6 +79,7 @@ data LinLiteral = FloatConstant Float data LinPattern = ParamPattern ParamPattern | RecordPattern [RecordRow LinPattern] + | TuplePattern [LinPattern] | WildPattern deriving (Eq,Ord,Show) @@ -213,6 +215,7 @@ instance Pretty LinValue where Projection lv l -> ppA lv<>"."<>l Selection tv pv -> ppA tv<>"!"<>ppA pv VariantValue vs -> "variants"<+>block vs + CommentedValue s v -> "{-" <+> s <+> "-}" $$ v _ -> ppA lv instance PPA LinValue where @@ -253,6 +256,7 @@ instance PPA LinPattern where ppA p = case p of RecordPattern r -> block r + TuplePattern ps -> "<"<>punctuate "," ps<>">" WildPattern -> pp "_" _ -> parens p -- cgit v1.2.3 From b11d7d93dcb22b26564f49158414f07f1bd3f4cc Mon Sep 17 00:00:00 2001 From: Thomas Hallgren Date: Wed, 13 Mar 2019 01:51:26 +0100 Subject: GF.Grammar.Canonical: some Functor/Foldable/Traversable instances --- src/compiler/GF/Compile/ConcreteToHaskell.hs | 10 +++++----- src/compiler/GF/Compile/GrammarToCanonical.hs | 10 +++++----- src/compiler/GF/Grammar/Canonical.hs | 17 +++++++++++------ src/compiler/GF/Grammar/CanonicalJSON.hs | 6 +++--- 4 files changed, 24 insertions(+), 19 deletions(-) (limited to 'src/compiler/GF/Grammar/Canonical.hs') diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs index 6d2bf398f..d74fcdacd 100644 --- a/src/compiler/GF/Compile/ConcreteToHaskell.hs +++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs @@ -194,8 +194,8 @@ concrete2haskell opts else LambdaCase (map ppCase cs) where (ds,ts') = dedup ts - (ps,ts) = unzip [(p,t)|TableRowValue p t<-cs] - ppCase (TableRowValue p t) = (ppP p,ppTv (patVars p++vs) t) + (ps,ts) = unzip [(p,t)|TableRow p t<-cs] + ppCase (TableRow p t) = (ppP p,ppTv (patVars p++vs) t) {- ppPredef n = case predef n of @@ -309,8 +309,8 @@ instance Records LinValue where Selection v1 v2 -> records (v1,v2) _ -> S.empty -instance Records TableRowValue where - records (TableRowValue _ v) = records v +instance Records rhs => Records (TableRow rhs) where + records (TableRow _ v) = records v -- | Record subtyping is converted into explicit coercions in Haskell @@ -318,7 +318,7 @@ coerce env ty t = case (ty,t) of (_,VariantValue ts) -> VariantValue (map (coerce env ty) ts) (TableType ti tv,TableValue _ cs) -> - TableValue ti [TableRowValue p (coerce env tv t)|TableRowValue p t<-cs] + TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs] (RecordType rt,RecordValue r) -> RecordValue [RecordRow l (coerce env ft f) | RecordRow l f<-r,ft<-[ft|RecordRow l' ft<-rt,l'==l]] diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs index 7442bd495..3b21f7702 100644 --- a/src/compiler/GF/Compile/GrammarToCanonical.hs +++ b/src/compiler/GF/Compile/GrammarToCanonical.hs @@ -151,7 +151,7 @@ convert' gr vs = ppT case t of -- Abs b x t -> ... -- V ty ts -> VTableValue (convType ty) (map ppT ts) - V ty ts -> TableValue (convType ty) [TableRowValue (ppP p) (ppT t)|(p,t)<-zip ps ts] + V ty ts -> TableValue (convType ty) [TableRow (ppP p) (ppT t)|(p,t)<-zip ps ts] where Ok pts = allParamValues gr ty Ok ps = mapM term2patt pts @@ -174,7 +174,7 @@ convert' gr vs = ppT Alts t' vs -> alts vs (ppT t') _ -> error $ "convert' "++show t - ppCase (p,t) = TableRowValue (ppP p) (ppTv (patVars p++vs) t) + ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t) ppPredef n = case predef n of @@ -249,19 +249,19 @@ proj r l = selection t v = case t of TableValue tt r -> - case nub [rv|TableRowValue _ rv<-keep] of + case nub [rv|TableRow _ rv<-keep] of [rv] -> rv _ -> Selection (TableValue tt r') v where r' = if null discard then r - else keep++[TableRowValue WildPattern impossible] + else keep++[TableRow WildPattern impossible] (keep,discard) = partition (mightMatchRow v) r _ -> Selection t v impossible = ErrorValue "impossible" -mightMatchRow v (TableRowValue p _) = +mightMatchRow v (TableRow p _) = case p of WildPattern -> True _ -> mightMatch v p diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs index 8be659e1b..ed4f3fc9e 100644 --- a/src/compiler/GF/Grammar/Canonical.hs +++ b/src/compiler/GF/Grammar/Canonical.hs @@ -7,6 +7,7 @@ -- by partial evaluation. This is intended as a common intermediate -- representation to simplify export to other formats. +{-# LANGUAGE DeriveTraversable #-} module GF.Grammar.Canonical where import Prelude hiding ((<>)) import GF.Text.Pretty @@ -87,13 +88,17 @@ type ParamValue = Param LinValue type ParamPattern = Param LinPattern type ParamValueDef = Param ParamId -data Param arg = Param ParamId [arg] deriving (Eq,Ord,Show) +data Param arg = Param ParamId [arg] + deriving (Eq,Ord,Show,Functor,Foldable,Traversable) -type RecordRowType = RecordRow LinType +type RecordRowType = RecordRow LinType type RecordRowValue = RecordRow LinValue +type TableRowValue = TableRow LinValue -data RecordRow rhs = RecordRow LabelId rhs deriving (Eq,Ord,Show) -data TableRowValue = TableRowValue LinPattern LinValue deriving (Eq,Ord,Show) +data RecordRow rhs = RecordRow LabelId rhs + deriving (Eq,Ord,Show,Functor,Foldable,Traversable) +data TableRow rhs = TableRow LinPattern rhs + deriving (Eq,Ord,Show,Functor,Foldable,Traversable) -- *** Identifiers in Concrete Syntax @@ -265,8 +270,8 @@ instance RhsSeparator LinPattern where rhsSep _ = pp "=" instance RhsSeparator rhs => Pretty (RecordRow rhs) where pp (RecordRow l v) = hang (l<+>rhsSep v) 2 v -instance Pretty TableRowValue where - pp (TableRowValue l v) = hang (l<+>"=>") 2 v +instance Pretty rhs => Pretty (TableRow rhs) where + pp (TableRow l v) = hang (l<+>"=>") 2 v -------------------------------------------------------------------------------- instance Pretty ModId where pp (ModId s) = pp s diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs index 8024fe99a..8b3464674 100644 --- a/src/compiler/GF/Grammar/CanonicalJSON.hs +++ b/src/compiler/GF/Grammar/CanonicalJSON.hs @@ -210,10 +210,10 @@ instance JSON a => JSON (RecordRow a) where where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue return (RecordRow (LabelId lbl) value) -instance JSON TableRowValue where - showJSON (TableRowValue l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)] +instance JSON rhs => JSON (TableRow rhs) where + showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)] - readJSON o = TableRowValue <$> o!".pattern" <*> o!".value" + readJSON o = TableRow <$> o!".pattern" <*> o!".value" -- *** Identifiers in Concrete Syntax -- cgit v1.2.3