mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-17 15:12:50 -06:00
Merge with master and drop the Haskell runtime completely
This commit is contained in:
krangelov
313
src/compiler/GF/Grammar/Canonical.hs
Normal file
313
src/compiler/GF/Grammar/Canonical.hs
Normal file
@@ -0,0 +1,313 @@
|
||||
-- |
|
||||
-- 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.
|
||||
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
module GF.Grammar.Canonical where
|
||||
import Prelude hiding ((<>))
|
||||
import GF.Text.Pretty
|
||||
|
||||
-- | A Complete grammar
|
||||
data Grammar = Grammar Abstract [Concrete] deriving Show
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** Abstract Syntax
|
||||
|
||||
-- | Abstract Syntax
|
||||
data Abstract = Abstract ModId Flags [CatDef] [FunDef] deriving Show
|
||||
abstrName (Abstract mn _ _ _) = mn
|
||||
|
||||
data CatDef = CatDef CatId [CatId] deriving Show
|
||||
data FunDef = FunDef FunId Type deriving Show
|
||||
data Type = Type [TypeBinding] TypeApp deriving Show
|
||||
data TypeApp = TypeApp CatId [Type] deriving Show
|
||||
|
||||
data TypeBinding = TypeBinding VarId Type deriving Show
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** Concreate syntax
|
||||
|
||||
-- | Concrete Syntax
|
||||
data Concrete = Concrete ModId ModId Flags [ParamDef] [LincatDef] [LinDef]
|
||||
deriving Show
|
||||
concName (Concrete cnc _ _ _ _ _) = cnc
|
||||
|
||||
data ParamDef = ParamDef ParamId [ParamValueDef]
|
||||
| ParamAliasDef ParamId LinType
|
||||
deriving Show
|
||||
data LincatDef = LincatDef CatId LinType deriving Show
|
||||
data LinDef = LinDef FunId [VarId] LinValue deriving Show
|
||||
|
||||
-- | Linearization type, RHS of @lincat@
|
||||
data LinType = FloatType
|
||||
| IntType
|
||||
| ParamType ParamType
|
||||
| RecordType [RecordRowType]
|
||||
| StrType
|
||||
| TableType LinType LinType
|
||||
| TupleType [LinType]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
|
||||
|
||||
-- | Linearization value, RHS of @lin@
|
||||
data LinValue = ConcatValue LinValue LinValue
|
||||
| LiteralValue LinLiteral
|
||||
| ErrorValue String
|
||||
| ParamConstant ParamValue
|
||||
| PredefValue PredefId
|
||||
| RecordValue [RecordRowValue]
|
||||
| TableValue LinType [TableRowValue]
|
||||
--- | VTableValue LinType [LinValue]
|
||||
| TupleValue [LinValue]
|
||||
| VariantValue [LinValue]
|
||||
| VarValue VarValueId
|
||||
| PreValue [([String], LinValue)] LinValue
|
||||
| Projection LinValue LabelId
|
||||
| Selection LinValue LinValue
|
||||
| CommentedValue String LinValue
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data LinLiteral = FloatConstant Float
|
||||
| IntConstant Int
|
||||
| StrConstant String
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data LinPattern = ParamPattern ParamPattern
|
||||
| RecordPattern [RecordRow LinPattern]
|
||||
| TuplePattern [LinPattern]
|
||||
| WildPattern
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
type ParamValue = Param LinValue
|
||||
type ParamPattern = Param LinPattern
|
||||
type ParamValueDef = Param ParamId
|
||||
|
||||
data Param arg = Param ParamId [arg]
|
||||
deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
|
||||
|
||||
type RecordRowType = RecordRow LinType
|
||||
type RecordRowValue = RecordRow LinValue
|
||||
type TableRowValue = TableRow LinValue
|
||||
|
||||
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
|
||||
|
||||
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 QualId deriving (Eq,Ord,Show)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** Used in both Abstract and Concrete Syntax
|
||||
|
||||
newtype ModId = ModId Id deriving (Eq,Ord,Show)
|
||||
|
||||
newtype CatId = CatId Id deriving (Eq,Ord,Show)
|
||||
newtype FunId = FunId Id deriving (Eq,Show)
|
||||
|
||||
data VarId = Anonymous | VarId Id deriving Show
|
||||
|
||||
newtype Flags = Flags [(FlagName,FlagValue)] deriving Show
|
||||
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
|
||||
|
||||
instance Pretty Grammar where
|
||||
pp (Grammar abs cncs) = abs $+$ vcat cncs
|
||||
|
||||
instance Pretty Abstract where
|
||||
pp (Abstract m flags cats funs) =
|
||||
"abstract" <+> m <+> "=" <+> "{" $$
|
||||
flags $$
|
||||
"cat" <+> fsep cats $$
|
||||
"fun" <+> vcat funs $$
|
||||
"}"
|
||||
|
||||
instance Pretty CatDef where
|
||||
pp (CatDef c cs) = hsep (c:cs)<>";"
|
||||
|
||||
instance Pretty FunDef where
|
||||
pp (FunDef f ty) = f <+> ":" <+> ty <>";"
|
||||
|
||||
instance Pretty Type where
|
||||
pp (Type bs ty) = sep (punctuate " ->" (map pp bs ++ [pp ty]))
|
||||
|
||||
instance PPA Type where
|
||||
ppA (Type [] (TypeApp c [])) = pp c
|
||||
ppA t = parens t
|
||||
|
||||
instance Pretty TypeBinding where
|
||||
pp (TypeBinding Anonymous (Type [] tapp)) = pp tapp
|
||||
pp (TypeBinding Anonymous ty) = parens ty
|
||||
pp (TypeBinding (VarId x) ty) = parens (x<+>":"<+>ty)
|
||||
|
||||
instance Pretty TypeApp where
|
||||
pp (TypeApp c targs) = c<+>hsep (map ppA targs)
|
||||
|
||||
instance Pretty VarId where
|
||||
pp Anonymous = pp "_"
|
||||
pp (VarId x) = pp x
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
instance Pretty Concrete where
|
||||
pp (Concrete cncid absid flags params lincats lins) =
|
||||
"concrete" <+> cncid <+> "of" <+> absid <+> "=" <+> "{" $$
|
||||
vcat params $$
|
||||
section "lincat" lincats $$
|
||||
section "lin" lins $$
|
||||
"}"
|
||||
where
|
||||
section name [] = empty
|
||||
section name ds = name <+> vcat (map (<> ";") ds)
|
||||
|
||||
instance Pretty ParamDef where
|
||||
pp (ParamDef p pvs) = hang ("param"<+> p <+> "=") 4 (punctuate " |" pvs)<>";"
|
||||
pp (ParamAliasDef p t) = hang ("oper"<+> p <+> "=") 4 t<>";"
|
||||
|
||||
instance PPA arg => Pretty (Param arg) where
|
||||
pp (Param p ps) = pp p<+>sep (map ppA ps)
|
||||
|
||||
instance PPA arg => PPA (Param arg) where
|
||||
ppA (Param p []) = pp p
|
||||
ppA pv = parens pv
|
||||
|
||||
instance Pretty LincatDef where
|
||||
pp (LincatDef c lt) = hang (c <+> "=") 4 lt
|
||||
|
||||
instance Pretty LinType where
|
||||
pp lt = case lt of
|
||||
FloatType -> pp "Float"
|
||||
IntType -> pp "Int"
|
||||
ParamType pt -> pp pt
|
||||
RecordType rs -> block rs
|
||||
StrType -> pp "Str"
|
||||
TableType pt lt -> sep [pt <+> "=>",pp lt]
|
||||
TupleType lts -> "<"<>punctuate "," lts<>">"
|
||||
|
||||
instance RhsSeparator LinType where rhsSep _ = pp ":"
|
||||
|
||||
instance Pretty ParamType where
|
||||
pp (ParamTypeId p) = pp p
|
||||
|
||||
instance Pretty LinDef where
|
||||
pp (LinDef f xs lv) = hang (f<+>hsep xs<+>"=") 4 lv
|
||||
|
||||
instance Pretty LinValue where
|
||||
pp lv = case lv of
|
||||
ConcatValue v1 v2 -> sep [v1 <+> "++",pp v2]
|
||||
ErrorValue s -> "Predef.error"<+>doubleQuotes s
|
||||
ParamConstant pv -> pp pv
|
||||
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
|
||||
ppA lv = case lv of
|
||||
LiteralValue l -> ppA l
|
||||
ParamConstant pv -> ppA pv
|
||||
PredefValue p -> ppA p
|
||||
RecordValue [] -> pp "<>"
|
||||
RecordValue rvs -> block rvs
|
||||
PreValue alts def ->
|
||||
"pre"<+>block (map alt alts++["_"<+>"=>"<+>def])
|
||||
where
|
||||
alt (ss,lv) = hang (hcat (punctuate "|" (map doubleQuotes ss)))
|
||||
2 ("=>"<+>lv)
|
||||
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
|
||||
pp p =
|
||||
case p of
|
||||
ParamPattern pv -> pp pv
|
||||
_ -> ppA p
|
||||
|
||||
instance PPA LinPattern where
|
||||
ppA p =
|
||||
case p of
|
||||
ParamPattern pv -> ppA pv
|
||||
RecordPattern r -> block r
|
||||
TuplePattern ps -> "<"<>punctuate "," ps<>">"
|
||||
WildPattern -> pp "_"
|
||||
_ -> parens p
|
||||
|
||||
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 rhs => Pretty (TableRow rhs) where
|
||||
pp (TableRow l v) = hang (l<+>"=>") 2 v
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
instance Pretty ModId where pp (ModId s) = pp s
|
||||
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) = "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)
|
||||
where
|
||||
ppFlag (name,value) = name <+> "=" <+> value <>";"
|
||||
|
||||
instance Pretty FlagValue where
|
||||
pp (Str s) = pp s
|
||||
pp (Int i) = pp i
|
||||
pp (Flt d) = pp d
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Pretty print atomically (i.e. wrap it in parentheses if necessary)
|
||||
class Pretty a => PPA a where ppA :: a -> Doc
|
||||
|
||||
class Pretty rhs => RhsSeparator rhs where rhsSep :: rhs -> Doc
|
||||
|
||||
semiSep xs = punctuate ";" xs
|
||||
block xs = braces (semiSep xs)
|
||||
289
src/compiler/GF/Grammar/CanonicalJSON.hs
Normal file
289
src/compiler/GF/Grammar/CanonicalJSON.hs
Normal file
@@ -0,0 +1,289 @@
|
||||
module GF.Grammar.CanonicalJSON (
|
||||
encodeJSON
|
||||
) where
|
||||
|
||||
import Text.JSON
|
||||
import Control.Applicative ((<|>))
|
||||
import Data.Ratio (denominator, numerator)
|
||||
import GF.Grammar.Canonical
|
||||
|
||||
|
||||
encodeJSON :: FilePath -> Grammar -> IO ()
|
||||
encodeJSON fpath g = writeFile fpath (encode g)
|
||||
|
||||
|
||||
-- in general we encode grammars using JSON objects/records,
|
||||
-- except for newtypes/coercions/direct values
|
||||
|
||||
-- the top-level definitions use normal record labels,
|
||||
-- but recursive types/values/ids use labels staring with a "."
|
||||
|
||||
instance JSON Grammar where
|
||||
showJSON (Grammar abs cncs) = makeObj [("abstract", showJSON abs), ("concretes", showJSON cncs)]
|
||||
|
||||
readJSON o = Grammar <$> o!"abstract" <*> o!"concretes"
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** Abstract Syntax
|
||||
|
||||
instance JSON Abstract where
|
||||
showJSON (Abstract absid flags cats funs)
|
||||
= makeObj [("abs", showJSON absid),
|
||||
("flags", showJSON flags),
|
||||
("cats", showJSON cats),
|
||||
("funs", showJSON funs)]
|
||||
|
||||
readJSON o = Abstract
|
||||
<$> o!"abs"
|
||||
<*>(o!"flags" <|> return (Flags []))
|
||||
<*> o!"cats"
|
||||
<*> o!"funs"
|
||||
|
||||
instance JSON CatDef where
|
||||
-- non-dependent categories are encoded as simple strings:
|
||||
showJSON (CatDef c []) = showJSON c
|
||||
showJSON (CatDef c cs) = makeObj [("cat", showJSON c), ("args", showJSON cs)]
|
||||
|
||||
readJSON o = CatDef <$> readJSON o <*> return []
|
||||
<|> CatDef <$> o!"cat" <*> o!"args"
|
||||
|
||||
instance JSON FunDef where
|
||||
showJSON (FunDef f ty) = makeObj [("fun", showJSON f), ("type", showJSON ty)]
|
||||
|
||||
readJSON o = FunDef <$> o!"fun" <*> o!"type"
|
||||
|
||||
instance JSON Type where
|
||||
showJSON (Type bs ty) = makeObj [(".args", showJSON bs), (".result", showJSON ty)]
|
||||
|
||||
readJSON o = Type <$> o!".args" <*> o!".result"
|
||||
|
||||
instance JSON TypeApp where
|
||||
-- non-dependent categories are encoded as simple strings:
|
||||
showJSON (TypeApp c []) = showJSON c
|
||||
showJSON (TypeApp c args) = makeObj [(".cat", showJSON c), (".args", showJSON args)]
|
||||
|
||||
readJSON o = TypeApp <$> readJSON o <*> return []
|
||||
<|> TypeApp <$> o!".cat" <*> o!".args"
|
||||
|
||||
instance JSON TypeBinding where
|
||||
-- non-dependent categories are encoded as simple strings:
|
||||
showJSON (TypeBinding Anonymous (Type [] (TypeApp c []))) = showJSON c
|
||||
showJSON (TypeBinding x ty) = makeObj [(".var", showJSON x), (".type", showJSON ty)]
|
||||
|
||||
readJSON o = do c <- readJSON o
|
||||
return (TypeBinding Anonymous (Type [] (TypeApp c [])))
|
||||
<|> TypeBinding <$> o!".var" <*> o!".type"
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** Concrete syntax
|
||||
|
||||
instance JSON Concrete where
|
||||
showJSON (Concrete cncid absid flags params lincats lins)
|
||||
= makeObj [("cnc", showJSON cncid),
|
||||
("abs", showJSON absid),
|
||||
("flags", showJSON flags),
|
||||
("params", showJSON params),
|
||||
("lincats", showJSON lincats),
|
||||
("lins", showJSON lins)]
|
||||
|
||||
readJSON o = Concrete
|
||||
<$> o!"cnc"
|
||||
<*> o!"abs"
|
||||
<*>(o!"flags" <|> return (Flags []))
|
||||
<*> o!"params"
|
||||
<*> o!"lincats"
|
||||
<*> o!"lins"
|
||||
|
||||
instance JSON ParamDef where
|
||||
showJSON (ParamDef p pvs) = makeObj [("param", showJSON p), ("values", showJSON pvs)]
|
||||
showJSON (ParamAliasDef p t) = makeObj [("param", showJSON p), ("alias", showJSON t)]
|
||||
|
||||
readJSON o = ParamDef <$> o!"param" <*> o!"values"
|
||||
<|> ParamAliasDef <$> o!"param" <*> o!"alias"
|
||||
|
||||
instance JSON LincatDef where
|
||||
showJSON (LincatDef c lt) = makeObj [("cat", showJSON c), ("lintype", showJSON lt)]
|
||||
|
||||
readJSON o = LincatDef <$> o!"cat" <*> o!"lintype"
|
||||
|
||||
instance JSON LinDef where
|
||||
showJSON (LinDef f xs lv) = makeObj [("fun", showJSON f), ("args", showJSON xs), ("lin", showJSON lv)]
|
||||
|
||||
readJSON o = LinDef <$> o!"fun" <*> o!"args" <*> o!"lin"
|
||||
|
||||
instance JSON LinType where
|
||||
-- the basic types (Str, Float, Int) are encoded as strings:
|
||||
showJSON (StrType) = showJSON "Str"
|
||||
showJSON (FloatType) = showJSON "Float"
|
||||
showJSON (IntType) = showJSON "Int"
|
||||
-- parameters are also encoded as strings:
|
||||
showJSON (ParamType pt) = showJSON pt
|
||||
-- tables/tuples are encoded as JSON objects:
|
||||
showJSON (TableType pt lt) = makeObj [(".tblarg", showJSON pt), (".tblval", showJSON lt)]
|
||||
showJSON (TupleType lts) = makeObj [(".tuple", showJSON lts)]
|
||||
-- records are encoded as records:
|
||||
showJSON (RecordType rows) = showJSON rows
|
||||
|
||||
readJSON o = do "Str" <- readJSON o; return StrType
|
||||
<|> do "Float" <- readJSON o; return FloatType
|
||||
<|> do "Int" <- readJSON o; return IntType
|
||||
<|> do ptype <- readJSON o; return (ParamType ptype)
|
||||
<|> TableType <$> o!".tblarg" <*> o!".tblval"
|
||||
<|> TupleType <$> o!".tuple"
|
||||
<|> RecordType <$> readJSON o
|
||||
|
||||
instance JSON LinValue where
|
||||
showJSON (LiteralValue l ) = showJSON l
|
||||
-- most values are encoded as JSON objects:
|
||||
showJSON (ParamConstant pv) = makeObj [(".param", showJSON pv)]
|
||||
showJSON (PredefValue p ) = makeObj [(".predef", showJSON p)]
|
||||
showJSON (TableValue t tvs) = makeObj [(".tblarg", showJSON t), (".tblrows", showJSON tvs)]
|
||||
showJSON (TupleValue lvs) = makeObj [(".tuple", showJSON lvs)]
|
||||
showJSON (VarValue v ) = makeObj [(".var", showJSON v)]
|
||||
showJSON (ErrorValue s ) = makeObj [(".error", showJSON s)]
|
||||
showJSON (Projection lv l ) = makeObj [(".project", showJSON lv), (".label", showJSON l)]
|
||||
showJSON (Selection tv pv) = makeObj [(".select", showJSON tv), (".key", showJSON pv)]
|
||||
showJSON (VariantValue vs) = makeObj [(".variants", showJSON vs)]
|
||||
showJSON (PreValue pre def) = makeObj [(".pre", showJSON pre),(".default", showJSON def)]
|
||||
-- records are encoded directly as JSON records:
|
||||
showJSON (RecordValue rows) = showJSON rows
|
||||
-- concatenation is encoded as a JSON array:
|
||||
showJSON v@(ConcatValue _ _) = showJSON (flatten v [])
|
||||
where flatten (ConcatValue v v') = flatten v . flatten v'
|
||||
flatten v = (v :)
|
||||
|
||||
readJSON o = LiteralValue <$> readJSON o
|
||||
<|> ParamConstant <$> o!".param"
|
||||
<|> PredefValue <$> o!".predef"
|
||||
<|> TableValue <$> o!".tblarg" <*> o!".tblrows"
|
||||
<|> TupleValue <$> o!".tuple"
|
||||
<|> VarValue <$> o!".var"
|
||||
<|> ErrorValue <$> o!".error"
|
||||
<|> Projection <$> o!".project" <*> o!".label"
|
||||
<|> Selection <$> o!".select" <*> o!".key"
|
||||
<|> VariantValue <$> o!".variants"
|
||||
<|> PreValue <$> o!".pre" <*> o!".default"
|
||||
<|> RecordValue <$> readJSON o
|
||||
<|> do vs <- readJSON o :: Result [LinValue]
|
||||
return (foldr1 ConcatValue vs)
|
||||
|
||||
instance JSON LinLiteral where
|
||||
-- basic values (Str, Float, Int) are encoded as JSON strings/numbers:
|
||||
showJSON (StrConstant s) = showJSON s
|
||||
showJSON (FloatConstant f) = showJSON f
|
||||
showJSON (IntConstant n) = showJSON n
|
||||
|
||||
readJSON = readBasicJSON StrConstant IntConstant FloatConstant
|
||||
|
||||
instance JSON LinPattern where
|
||||
-- wildcards and patterns without arguments are encoded as strings:
|
||||
showJSON (WildPattern) = showJSON "_"
|
||||
showJSON (ParamPattern (Param p [])) = showJSON p
|
||||
-- complex patterns are encoded as JSON objects:
|
||||
showJSON (ParamPattern pv) = showJSON pv
|
||||
-- and records as records:
|
||||
showJSON (RecordPattern r) = showJSON r
|
||||
|
||||
readJSON o = do "_" <- readJSON o; return WildPattern
|
||||
<|> do p <- readJSON o; return (ParamPattern (Param p []))
|
||||
<|> ParamPattern <$> readJSON o
|
||||
<|> RecordPattern <$> readJSON o
|
||||
|
||||
instance JSON arg => JSON (Param arg) where
|
||||
-- parameters without arguments are encoded as strings:
|
||||
showJSON (Param p []) = showJSON p
|
||||
showJSON (Param p args) = makeObj [(".paramid", showJSON p), (".args", showJSON args)]
|
||||
|
||||
readJSON o = Param <$> readJSON o <*> return []
|
||||
<|> Param <$> o!".paramid" <*> o!".args"
|
||||
|
||||
instance JSON a => JSON (RecordRow a) where
|
||||
-- record rows and lists of record rows are both encoded as JSON records (i.e., objects)
|
||||
showJSON row = showJSONs [row]
|
||||
showJSONs rows = makeObj (map toRow rows)
|
||||
where toRow (RecordRow (LabelId lbl) val) = (lbl, showJSON val)
|
||||
|
||||
readJSON obj = head <$> readJSONs obj
|
||||
readJSONs obj = mapM fromRow (assocsJSObject obj)
|
||||
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
|
||||
return (RecordRow (LabelId lbl) value)
|
||||
|
||||
instance JSON rhs => JSON (TableRow rhs) where
|
||||
showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
|
||||
|
||||
readJSON o = TableRow <$> o!".pattern" <*> o!".value"
|
||||
|
||||
|
||||
-- *** Identifiers in Concrete Syntax
|
||||
|
||||
instance JSON PredefId where showJSON (PredefId s) = showJSON s ; readJSON = fmap PredefId . readJSON
|
||||
instance JSON LabelId where showJSON (LabelId s) = showJSON s ; readJSON = fmap LabelId . readJSON
|
||||
instance JSON VarValueId where showJSON (VarValueId s) = showJSON s ; readJSON = fmap VarValueId . readJSON
|
||||
instance JSON ParamId where showJSON (ParamId s) = showJSON s ; readJSON = fmap ParamId . readJSON
|
||||
instance JSON ParamType where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** Used in both Abstract and Concrete Syntax
|
||||
|
||||
instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON
|
||||
instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON
|
||||
instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON
|
||||
|
||||
instance JSON VarId where
|
||||
-- the anonymous variable is the underscore:
|
||||
showJSON Anonymous = showJSON "_"
|
||||
showJSON (VarId x) = showJSON x
|
||||
|
||||
readJSON o = do "_" <- readJSON o; return Anonymous
|
||||
<|> VarId <$> readJSON o
|
||||
|
||||
instance JSON QualId where
|
||||
showJSON (Qual (ModId m) n) = showJSON (m++"."++n)
|
||||
showJSON (Unqual n) = showJSON n
|
||||
|
||||
readJSON o = do qualid <- readJSON o
|
||||
let (mod, id) = span (/= '.') qualid
|
||||
return $ if null mod then Unqual id else Qual (ModId mod) id
|
||||
|
||||
instance JSON Flags where
|
||||
-- flags are encoded directly as JSON records (i.e., objects):
|
||||
showJSON (Flags fs) = makeObj [(f, showJSON v) | (f, v) <- fs]
|
||||
|
||||
readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
|
||||
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
|
||||
return (lbl, value)
|
||||
|
||||
instance JSON FlagValue where
|
||||
-- flag values are encoded as basic JSON types:
|
||||
showJSON (Str s) = showJSON s
|
||||
showJSON (Int i) = showJSON i
|
||||
showJSON (Flt f) = showJSON f
|
||||
|
||||
readJSON = readBasicJSON Str Int Flt
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** Convenience functions
|
||||
|
||||
(!) :: JSON a => JSValue -> String -> Result a
|
||||
obj ! key = maybe (fail $ "CanonicalJSON.(!): Could not find key: " ++ show key)
|
||||
readJSON
|
||||
(lookup key (assocsJSObject obj))
|
||||
|
||||
assocsJSObject :: JSValue -> [(String, JSValue)]
|
||||
assocsJSObject (JSObject o) = fromJSObject o
|
||||
assocsJSObject (JSArray _) = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found an Array"
|
||||
assocsJSObject jsvalue = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found " ++ show jsvalue
|
||||
|
||||
|
||||
readBasicJSON :: (JSON int, Integral int, JSON flt, RealFloat flt) =>
|
||||
(String -> v) -> (int -> v) -> (flt -> v) -> JSValue -> Result v
|
||||
readBasicJSON str int flt o
|
||||
= str <$> readJSON o
|
||||
<|> int_or_flt <$> readJSON o
|
||||
where int_or_flt f | f == fromIntegral n = int n
|
||||
| otherwise = flt f
|
||||
where n = round f
|
||||
@@ -208,7 +208,7 @@ ppTerm q d (S x y) = case x of
|
||||
ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y)
|
||||
ppTerm q d (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)
|
||||
ppTerm q d (V e es) = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
|
||||
ppTerm q d (FV es) = "variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
|
||||
ppTerm q d (FV es) = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))))
|
||||
ppTerm q d (AdHocOverload es) = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
|
||||
ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
|
||||
ppTerm q d (Strs es) = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
|
||||
|
||||
Reference in New Issue
Block a user