msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Remove LF prefix from constructors. Pass all unit tests and Foods again, but improvements/cleanup still necessary.

Browse Source
This commit is contained in:
John J. Camilleri
2021-03-03 09:19:52 +01:00
parent 33e0e98aec
commit 4c09e4a340
5 changed files with 208 additions and 139 deletions
Download Patch File Download Diff File Expand all files Collapse all files

140
src/compiler/GF/Compile/GrammarToLPGF.hs
View File

@@ -1,6 +1,6 @@
module GF.Compile.GrammarToLPGF (mkCanon2lpgf) where module GF.Compile.GrammarToLPGF (mkCanon2lpgf) where
import LPGF (LPGF (..), LinFun (..)) import LPGF (LPGF (..))
import qualified LPGF as L import qualified LPGF as L
import PGF.CId import PGF.CId
@@ -46,12 +46,14 @@ mkCanon2lpgf opts gr am = do
mkAbstract :: C.Abstract -> IOE (CId, L.Abstract) mkAbstract :: C.Abstract -> IOE (CId, L.Abstract)
mkAbstract (C.Abstract modId flags cats funs) = return (mdi2i modId, L.Abstract {}) mkAbstract (C.Abstract modId flags cats funs) = return (mdi2i modId, L.Abstract {})
mkConcrete :: C.Concrete -> IOE (CId, L.Concrete) -- TODO don't need IO mkConcrete :: C.Concrete -> IOE (CId, L.Concrete) -- TODO don't need IO, use ErrM
mkConcrete (C.Concrete modId absModId flags params lincats lindefs) = do mkConcrete (C.Concrete modId absModId flags params' lincats lindefs) = do
let let
(C.Abstract _ _ _ funs) = ab (C.Abstract _ _ _ funs) = ab
paramTuples = mkParamTuples params params = inlineParamAliases params' -- TODO remove by making mkParamTuples return map
paramTuples = mkParamTuples params'
-- mapM_ (\(C.ParamDef (C.ParamId (C.Qual _ pid)) _,ptup) -> putStrLn $ "# " ++ pid ++ "\n" ++ T.unpack (L.render $ L.pp ptup)) (zip params paramTuples) -- mapM_ (\(C.ParamDef (C.ParamId (C.Qual _ pid)) _,ptup) -> putStrLn $ "# " ++ pid ++ "\n" ++ T.unpack (L.render $ L.pp ptup)) (zip params paramTuples)
let
-- filter out record fields from defn which don't appear in lincat -- filter out record fields from defn which don't appear in lincat
-- this seems to be an inconsistency in the canonical representation -- this seems to be an inconsistency in the canonical representation
@@ -91,14 +93,14 @@ mkCanon2lpgf opts gr am = do
C.ConcatValue v1 v2 -> do C.ConcatValue v1 v2 -> do
(v1',t1) <- val2lin v1 (v1',t1) <- val2lin v1
(v2',t2) <- val2lin v2 (v2',t2) <- val2lin v2
return (L.LFConcat v1' v2', t1 <|> t2) -- t1 else t2 return (L.Concat v1' v2', t1 <|> t2) -- t1 else t2
C.LiteralValue ll -> case ll of C.LiteralValue ll -> case ll of
C.FloatConstant f -> return (L.LFToken $ T.pack $ show f, Just C.FloatType) C.FloatConstant f -> return (L.Token $ T.pack $ show f, Just C.FloatType)
C.IntConstant i -> return (L.LFToken $ T.pack $ show i, Just C.IntType) C.IntConstant i -> return (L.Token $ T.pack $ show i, Just C.IntType)
C.StrConstant s -> return (L.LFToken $ T.pack s, Just C.StrType) C.StrConstant s -> return (L.Token $ T.pack s, Just C.StrType)
C.ErrorValue err -> return (L.LFError err, Nothing) C.ErrorValue err -> return (L.Error err, Nothing)
-- the expressions built here can be quite large, -- the expressions built here can be quite large,
-- but will be reduced during optimisation if possible -- but will be reduced during optimisation if possible
@@ -111,9 +113,9 @@ mkCanon2lpgf opts gr am = do
let (C.ParamDef tpid defpids) = def let (C.ParamDef tpid defpids) = def
pidIx <- eitherElemIndex pid [ p | C.Param p _ <- defpids ] pidIx <- eitherElemIndex pid [ p | C.Param p _ <- defpids ]
rest <- mapM collectProjections lvs rest <- mapM collectProjections lvs
return $ L.LFInt (pidIx+1) : concat rest return $ L.Ix (pidIx+1) : concat rest
collectProjections lv = do collectProjections lv = do
(lf ,_) <- val2lin lv (lf,_) <- val2lin lv
return [lf] return [lf]
-- get param group index and defn for this constructor -- get param group index and defn for this constructor
@@ -121,24 +123,45 @@ mkCanon2lpgf opts gr am = do
`headOrLeft` printf "Cannot find param group: %s" (show pid) `headOrLeft` printf "Cannot find param group: %s" (show pid)
let (C.ParamDef tpid _) = def let (C.ParamDef tpid _) = def
let tuple = paramTuples !! gix -- let tuple = paramTuples !! gix
lfs <- collectProjections lv lfs <- collectProjections lv
let term = foldl L.LFProjection tuple lfs -- let term = foldl L.Projection tuple lfs
let term = L.Tuple lfs -- unapplied!
return (term, Just $ C.ParamType (C.ParamTypeId tpid)) return (term, Just $ C.ParamType (C.ParamTypeId tpid))
C.Selection v1 v2 -> do
(v1', t1) <- val2lin v1
(v2', t2) <- val2lin v2
-- let Just (C.TableType t11 t12) = t1 -- t11 == t2
case t1 of
Just (C.TableType (C.ParamType (C.ParamTypeId pid)) tret) -> do
(gix,_) <- [ (gix,d) | (gix,d@(C.ParamDef p _)) <- zip [0..] params, p == pid ]
`headOrLeft` printf "Cannot find param group: %s" (show pid)
let tuple = paramTuples !! gix
let v2'' = case v2' of
L.Tuple lfs -> foldl L.Projection tuple lfs
lf -> L.Projection tuple lf
return (L.Projection v1' v2'', Just tret)
Just (C.TableType (C.RecordType rrts) tret) ->
return (L.Projection v1' v2', Just tret)
_ -> Left $ printf "Unhandled type in selection: %s" (show t1)
C.PredefValue (C.PredefId pid) -> case pid of C.PredefValue (C.PredefId pid) -> case pid of
"BIND" -> return (L.LFBind, Nothing) "BIND" -> return (L.Bind, Nothing)
"SOFT_BIND" -> return (L.LFBind, Nothing) "SOFT_BIND" -> return (L.Bind, Nothing)
"SOFT_SPACE" -> return (L.LFSpace, Nothing) "SOFT_SPACE" -> return (L.Space, Nothing)
"CAPIT" -> return (L.LFCapit, Nothing) "CAPIT" -> return (L.Capit, Nothing)
"ALL_CAPIT" -> return (L.LFAllCapit, Nothing) "ALL_CAPIT" -> return (L.AllCapit, Nothing)
_ -> Left $ printf "Unknown predef function: %s" pid _ -> Left $ printf "Unknown predef function: %s" pid
C.RecordValue rrvs -> do C.RecordValue rrvs -> do
let rrvs' = sortRecordRows rrvs let rrvs' = sortRecordRows rrvs
ts <- sequence [ val2lin lv | C.RecordRow lid lv <- rrvs' ] ts <- sequence [ val2lin lv | C.RecordRow lid lv <- rrvs' ]
return (L.LFTuple (map fst ts), Just $ C.RecordType [ C.RecordRow lid lt | (C.RecordRow lid _, (_, Just lt)) <- zip rrvs' ts]) return (L.Tuple (map fst ts), Just $ C.RecordType [ C.RecordRow lid lt | (C.RecordRow lid _, (_, Just lt)) <- zip rrvs' ts])
C.TableValue lt trvs | isRecordType lt -> go trvs C.TableValue lt trvs | isRecordType lt -> go trvs
where where
@@ -147,32 +170,38 @@ mkCanon2lpgf opts gr am = do
go trvs = do go trvs = do
let grps = L.groupBy (\(C.TableRow (C.RecordPattern rps1) _) (C.TableRow (C.RecordPattern rps2) _) -> head rps1 == head rps2) trvs let grps = L.groupBy (\(C.TableRow (C.RecordPattern rps1) _) (C.TableRow (C.RecordPattern rps2) _) -> head rps1 == head rps2) trvs
ts <- mapM (go . map (\(C.TableRow (C.RecordPattern rps) lv) -> C.TableRow (C.RecordPattern (tail rps)) lv)) grps ts <- mapM (go . map (\(C.TableRow (C.RecordPattern rps) lv) -> C.TableRow (C.RecordPattern (tail rps)) lv)) grps
return (L.LFTuple (map fst ts), Just lt) let typ = case ts of
(_, Just tst):_ -> Just $ C.TableType lt tst
_ -> Nothing
return (L.Tuple (map fst ts), typ)
C.TableValue lt trvs | isParamType lt -> do C.TableValue lt trvs | isParamType lt -> do
ts <- sequence [ val2lin lv | C.TableRow _ lv <- trvs ] ts <- sequence [ val2lin lv | C.TableRow _ lv <- trvs ]
return (L.LFTuple (map fst ts), Just lt) let typ = case ts of
(_, Just tst):_ -> Just $ C.TableType lt tst
_ -> Nothing
return (L.Tuple (map fst ts), typ)
-- TODO TuplePattern, WildPattern? -- TODO TuplePattern, WildPattern?
C.TupleValue lvs -> do C.TupleValue lvs -> do
ts <- mapM val2lin lvs ts <- mapM val2lin lvs
return (L.LFTuple (map fst ts), Just $ C.TupleType (map (fromJust.snd) ts)) return (L.Tuple (map fst ts), Just $ C.TupleType (map (fromJust.snd) ts))
C.VariantValue [] -> return (L.LFEmpty, Nothing) C.VariantValue [] -> return (L.Empty, Nothing)
C.VariantValue (vr:_) -> val2lin vr -- NOTE variants not supported, just pick first C.VariantValue (vr:_) -> val2lin vr -- NOTE variants not supported, just pick first
C.VarValue (C.VarValueId (C.Unqual v)) -> do C.VarValue (C.VarValueId (C.Unqual v)) -> do
ix <- eitherElemIndex (C.VarId v) varIds ix <- eitherElemIndex (C.VarId v) varIds
lt <- lookupLinTypeArg funId ix lt <- lookupLinTypeArg funId ix
return (L.LFArgument (ix+1), Just lt) return (L.Argument (ix+1), Just lt)
C.PreValue pts df -> do C.PreValue pts df -> do
pts' <- forM pts $ \(pfxs, lv) -> do pts' <- forM pts $ \(pfxs, lv) -> do
(lv', _) <- val2lin lv (lv', _) <- val2lin lv
return (map T.pack pfxs, lv') return (map T.pack pfxs, lv')
(df', lt) <- val2lin df (df', lt) <- val2lin df
return (L.LFPre pts' df', lt) return (L.Pre pts' df', lt)
C.Projection v1 lblId -> do C.Projection v1 lblId -> do
(v1', mtyp) <- val2lin v1 (v1', mtyp) <- val2lin v1
@@ -186,13 +215,13 @@ mkCanon2lpgf opts gr am = do
Left _ -> 0 -- corresponds to Prelude.False Left _ -> 0 -- corresponds to Prelude.False
-- lookup lintype for record row -- lookup lintype for record row
let C.RecordRow _ lt = rrs !! lblIx let C.RecordRow _ lt = rrs !! lblIx
return (L.LFProjection v1' (L.LFInt (lblIx+1)), Just lt) return (L.Projection v1' (L.Ix (lblIx+1)), Just lt)
C.Selection v1 v2 -> do -- C.Selection v1 v2 -> do
(v1', t1) <- val2lin v1 -- (v1', t1) <- val2lin v1
(v2', t2) <- val2lin v2 -- (v2', t2) <- val2lin v2
let Just (C.TableType t11 t12) = t1 -- let Just (C.TableType t11 t12) = t1
return (L.LFProjection v1' v2', Just t12) -- return (L.Projection v1' v2', Just t12)
C.CommentedValue cmnt lv -> val2lin lv C.CommentedValue cmnt lv -> val2lin lv
@@ -229,15 +258,15 @@ mkParamTuples defs = map (addIndexes . mk') pdefs
pdefs = inlineParamAliases defs pdefs = inlineParamAliases defs
mk' :: C.ParamDef -> L.LinFun mk' :: C.ParamDef -> L.LinFun
mk' (C.ParamDef _ pids) = L.LFTuple $ map mk'' pids mk' (C.ParamDef _ pids) = L.Tuple $ map mk'' pids
mk' (C.ParamAliasDef _ _) = error "mkParamTuples not implemented for ParamAliasDef" mk' (C.ParamAliasDef _ _) = error "mkParamTuples not implemented for ParamAliasDef"
mk'' :: C.ParamValueDef -> L.LinFun mk'' :: C.ParamValueDef -> L.LinFun
mk'' (C.Param _ []) = LFEmpty -- placeholder for terminal node, replaced later mk'' (C.Param _ []) = L.Empty -- placeholder for terminal node, replaced later
mk'' x@(C.Param p0 [pid]) = -- mk'' x@(C.Param p0 [pid]) =
let Just def = L.find (\(C.ParamDef p _) -> pid == p) pdefs -- let Just def = L.find (\(C.ParamDef p _) -> pid == p) pdefs
in mk' def -- in mk' def
-- mk'' x@(C.Param p0 [pid1,pid2]) = -- mk'' x@(C.Param p0 [pid1,pid2]) =
-- let -- let
@@ -254,27 +283,26 @@ mkParamTuples defs = map (addIndexes . mk') pdefs
rest = mk'' (C.Param p0 pids) rest = mk'' (C.Param p0 pids)
in replaceEmpty rest this in replaceEmpty rest this
-- traverse LinFun term and replace Empty with sequential index -- | Traverse LinFun term and replace Empty with sequential index
addIndexes :: L.LinFun -> L.LinFun addIndexes :: L.LinFun -> L.LinFun
addIndexes lf = CMS.evalState (num lf) 1 addIndexes lf = CMS.evalState (num lf) 1
where where
num :: L.LinFun -> CMS.State Int L.LinFun num :: L.LinFun -> CMS.State Int L.LinFun
num lf = case lf of num lf = case lf of
L.LFEmpty -> do L.Empty -> do
ix <- CMS.get ix <- CMS.get
CMS.modify (+1) CMS.modify (+1)
return $ L.LFInt ix return $ L.Ix ix
L.LFTuple lfs -> L.LFTuple <$> mapM num lfs L.Tuple lfs -> L.Tuple <$> mapM num lfs
x -> error $ "mkParamTuples.number not implemented for: " ++ show x x -> error $ "mkParamTuples.number not implemented for: " ++ show x
-- traverse LinFun term and replace Empty with given term -- | Traverse LinFun term and replace Empty with given term
replaceEmpty :: L.LinFun -> L.LinFun -> L.LinFun replaceEmpty :: L.LinFun -> L.LinFun -> L.LinFun
replaceEmpty with tree = case tree of replaceEmpty with tree = case tree of
L.LFEmpty -> with L.Empty -> with
L.LFTuple lfs -> L.LFTuple $ map (replaceEmpty with) lfs L.Tuple lfs -> L.Tuple $ map (replaceEmpty with) lfs
x -> error $ "mkParamTuples.replaceEmpty not implemented for: " ++ show x x -> error $ "mkParamTuples.replaceEmpty not implemented for: " ++ show x
-- | Always put 's' reocord field first, then sort alphabetically -- | Always put 's' reocord field first, then sort alphabetically
-- This seems to be done inconsistently in the canonical format -- This seems to be done inconsistently in the canonical format
-- Based on GF.Granmar.Macros.sortRec -- Based on GF.Granmar.Macros.sortRec
@@ -308,16 +336,32 @@ isParamConstant :: C.LinValue -> Bool
isParamConstant (C.ParamConstant (C.Param _ lvs)) = all isParamConstant lvs isParamConstant (C.ParamConstant (C.Param _ lvs)) = all isParamConstant lvs
isParamConstant _ = False isParamConstant _ = False
isLFInt :: L.LinFun -> Bool isIx :: L.LinFun -> Bool
isLFInt (L.LFInt _) = True isIx (L.Ix _) = True
isLFInt _ = False isIx _ = False
-- | Minimise a linfun by evaluating projections where possible
-- This code closely matches the runtime's `eval` function, except we have no context
reduce :: L.LinFun -> L.LinFun
reduce lf = case lf of
L.Pre pts df -> L.Pre pts' df'
where
pts' = [ (strs,reduce t) | (strs,t) <- pts]
df' = reduce df
L.Concat s t -> L.Concat (reduce s) (reduce t)
L.Tuple ts -> L.Tuple (map reduce ts)
L.Projection t u ->
case (reduce t, reduce u) of
(L.Tuple vs, L.Ix i) -> reduce $ vs !! (i-1)
(tp@(L.Tuple _), L.Tuple is) | all L.isIx is -> foldl (\(L.Tuple vs) (L.Ix i) -> vs !! (i-1)) tp is
(t',u') -> L.Projection t' u'
t -> t
-- | If list is non-empty return its head, else a fallback value -- | If list is non-empty return its head, else a fallback value
headOrLeft :: [a] -> b -> Either b a headOrLeft :: [a] -> b -> Either b a
headOrLeft (a:_) _ = Right a headOrLeft (a:_) _ = Right a
headOrLeft _ b = Left b headOrLeft _ b = Left b
-- | Convert Maybe to Either value with error -- | Convert Maybe to Either value with error
m2e :: String -> Maybe a -> Either String a m2e :: String -> Maybe a -> Either String a
m2e err = maybe (Left err) Right m2e err = maybe (Left err) Right

186
src/runtime/haskell/LPGF.hs
View File

@@ -4,6 +4,7 @@
-- | Linearisation-only grammar format. -- | Linearisation-only grammar format.
-- Closely follows description in Section 2 of Angelov, Bringert, Ranta (2009): -- Closely follows description in Section 2 of Angelov, Bringert, Ranta (2009):
-- "PGF: A Portable Run-Time Format for Type-Theoretical Grammars". -- "PGF: A Portable Run-Time Format for Type-Theoretical Grammars".
-- http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.640.6330&rep=rep1&type=pdf
module LPGF where module LPGF where
import PGF (Language) import PGF (Language)
@@ -46,30 +47,30 @@ newtype Concrete = Concrete {
-- -- | Linearisation type -- -- | Linearisation type
-- data LinType = -- data LinType =
-- LTStr -- StrType
-- | LTInt Int -- | IxType Int
-- | LTProduct [LinType] -- | ProductType [LinType]
-- deriving (Show) -- deriving (Show)
-- | Linearisation function -- | Linearisation function
data LinFun = data LinFun =
-- Additions -- Additions
LFError String -- ^ a runtime error, should probably not be supported at all Error String -- ^ a runtime error, should probably not be supported at all
| LFBind -- ^ join adjacent tokens | Bind -- ^ join adjacent tokens
| LFSpace -- ^ space between adjacent tokens | Space -- ^ space between adjacent tokens
| LFCapit -- ^ capitalise next character | Capit -- ^ capitalise next character
| LFAllCapit -- ^ capitalise next word | AllCapit -- ^ capitalise next word
| LFPre [([Text], LinFun)] LinFun | Pre [([Text], LinFun)] LinFun
| LFMissing CId -- ^ missing definition (inserted at runtime) | Missing CId -- ^ missing definition (inserted at runtime)
-- From original definition in paper -- From original definition in paper
| LFEmpty | Empty
| LFToken Text | Token Text
| LFConcat LinFun LinFun | Concat LinFun LinFun
| LFInt Int | Ix Int
| LFTuple [LinFun] | Tuple [LinFun]
| LFProjection LinFun LinFun | Projection LinFun LinFun
| LFArgument Int | Argument Int
deriving (Show, Read) deriving (Show, Read)
instance Binary LPGF where instance Binary LPGF where
@@ -101,37 +102,37 @@ instance Binary Concrete where
instance Binary LinFun where instance Binary LinFun where
put = \case put = \case
LFError e -> putWord8 0 >> put e Error e -> putWord8 0 >> put e
LFBind -> putWord8 1 Bind -> putWord8 1
LFSpace -> putWord8 2 Space -> putWord8 2
LFCapit -> putWord8 3 Capit -> putWord8 3
LFAllCapit -> putWord8 4 AllCapit -> putWord8 4
LFPre ps d -> putWord8 5 >> put ([(map TE.encodeUtf8 p,l) | (p,l) <- ps],d) Pre ps d -> putWord8 5 >> put ([(map TE.encodeUtf8 p,l) | (p,l) <- ps],d)
LFMissing f -> putWord8 13 >> put f Missing f -> putWord8 13 >> put f
LFEmpty -> putWord8 6 Empty -> putWord8 6
LFToken t -> putWord8 7 >> put (TE.encodeUtf8 t) Token t -> putWord8 7 >> put (TE.encodeUtf8 t)
LFConcat l1 l2 -> putWord8 8 >> put (l1,l2) Concat l1 l2 -> putWord8 8 >> put (l1,l2)
LFInt i -> putWord8 9 >> put i Ix i -> putWord8 9 >> put i
LFTuple ls -> putWord8 10 >> put ls Tuple ls -> putWord8 10 >> put ls
LFProjection l1 l2 -> putWord8 11 >> put (l1,l2) Projection l1 l2 -> putWord8 11 >> put (l1,l2)
LFArgument i -> putWord8 12 >> put i Argument i -> putWord8 12 >> put i
get = do get = do
tag <- getWord8 tag <- getWord8
case tag of case tag of
0 -> liftM LFError get 0 -> liftM Error get
1 -> return LFBind 1 -> return Bind
2 -> return LFSpace 2 -> return Space
3 -> return LFCapit 3 -> return Capit
4 -> return LFAllCapit 4 -> return AllCapit
5 -> liftM2 (\ps -> LFPre [(map TE.decodeUtf8 p,l) | (p,l) <- ps]) get get 5 -> liftM2 (\ps -> Pre [(map TE.decodeUtf8 p,l) | (p,l) <- ps]) get get
13 -> liftM LFMissing get 13 -> liftM Missing get
6 -> return LFEmpty 6 -> return Empty
7 -> liftM (LFToken . TE.decodeUtf8) get 7 -> liftM (Token . TE.decodeUtf8) get
8 -> liftM2 LFConcat get get 8 -> liftM2 Concat get get
9 -> liftM LFInt get 9 -> liftM Ix get
10 -> liftM LFTuple get 10 -> liftM Tuple get
11 -> liftM2 LFProjection get get 11 -> liftM2 Projection get get
12 -> liftM LFArgument get 12 -> liftM Argument get
_ -> fail "Failed to decode LPGF binary format" _ -> fail "Failed to decode LPGF binary format"
abstractName :: LPGF -> CId abstractName :: LPGF -> CId
@@ -168,7 +169,7 @@ linearizeConcreteText concr expr = lin2string $ lin (expr2tree expr)
case Map.lookup f (lins concr) of case Map.lookup f (lins concr) of
Just t -> eval (map lin as) t Just t -> eval (map lin as) t
-- _ -> error $ printf "Lookup failed for function: %s" (showCId f) -- _ -> error $ printf "Lookup failed for function: %s" (showCId f)
_ -> LFMissing f _ -> Missing f
x -> error $ printf "Cannot lin: %s" (prTree x) x -> error $ printf "Cannot lin: %s" (prTree x)
-- | Evaluation context is a sequence of terms -- | Evaluation context is a sequence of terms
@@ -177,48 +178,53 @@ type Context = [LinFun]
-- | Operational semantics -- | Operational semantics
eval :: Context -> LinFun -> LinFun eval :: Context -> LinFun -> LinFun
eval cxt t = case t of eval cxt t = case t of
LFError err -> error err Error err -> error err
LFPre pts df -> LFPre pts' df' Pre pts df -> Pre pts' df'
where where
pts' = [ (strs, eval cxt t) | (strs,t) <- pts] pts' = [ (strs, eval cxt t) | (strs,t) <- pts]
df' = eval cxt df df' = eval cxt df
LFConcat s t -> LFConcat v w Concat s t -> Concat v w
where where
v = eval cxt s v = eval cxt s
w = eval cxt t w = eval cxt t
LFTuple ts -> LFTuple vs Tuple ts -> Tuple vs
where vs = map (eval cxt) ts where vs = map (eval cxt) ts
LFProjection t u -> Projection t u ->
case (eval cxt t, eval cxt u) of case (eval cxt t, eval cxt u) of
(LFMissing f, _) -> LFMissing f (Missing f, _) -> Missing f
(_, LFMissing f) -> LFMissing f (_, Missing f) -> Missing f
(LFTuple vs, LFInt i) -> vs !! (i-1) (Tuple vs, Ix i) -> vs !! (i-1)
(tp@(LFTuple _), LFTuple is) | all isInt is -> foldl (\(LFTuple vs) (LFInt i) -> vs !! (i-1)) tp is (tp@(Tuple _), tv@(Tuple _)) | all isIx (flattenTuple tv) -> foldl (\(Tuple vs) (Ix i) -> vs !! (i-1)) tp (flattenTuple tv)
(t',u') -> error $ printf "Incompatible projection:\n- %s ~> %s\n- %s ~> %s" (show t) (show t') (show u) (show u') (t',u') -> error $ printf "Incompatible projection:\n- %s\n⇓ %s\n- %s\n⇓ %s" (show t) (show t') (show u) (show u')
LFArgument i -> cxt !! (i-1) Argument i -> cxt !! (i-1)
_ -> t _ -> t
flattenTuple :: LinFun -> [LinFun]
flattenTuple = \case
Tuple vs -> concatMap flattenTuple vs
lf -> [lf]
-- | Turn concrete syntax terms into an actual string -- | Turn concrete syntax terms into an actual string
lin2string :: LinFun -> Text lin2string :: LinFun -> Text
lin2string l = case l of lin2string l = case l of
LFEmpty -> "" Empty -> ""
LFBind -> "" -- when encountered at beginning/end Bind -> "" -- when encountered at beginning/end
LFSpace -> "" -- when encountered at beginning/end Space -> "" -- when encountered at beginning/end
LFToken tok -> tok Token tok -> tok
LFMissing cid -> T.pack $ printf "[%s]" (show cid) Missing cid -> T.pack $ printf "[%s]" (show cid)
LFTuple [l] -> lin2string l Tuple [l] -> lin2string l
LFTuple (l:_) -> lin2string l -- unselected table, just choose first option (see e.g. FoodsJpn) Tuple (l:_) -> lin2string l -- unselected table, just choose first option (see e.g. FoodsJpn)
LFPre pts df -> lin2string df -- when encountered at end Pre pts df -> lin2string df -- when encountered at end
LFConcat (LFPre pts df) l2 -> lin2string $ LFConcat l1 l2 Concat (Pre pts df) l2 -> lin2string $ Concat l1 l2
where where
l2' = lin2string l2 l2' = lin2string l2
matches = [ l | (pfxs, l) <- pts, any (`T.isPrefixOf` l2') pfxs ] matches = [ l | (pfxs, l) <- pts, any (`T.isPrefixOf` l2') pfxs ]
l1 = if null matches then df else head matches l1 = if null matches then df else head matches
LFConcat l1 (LFConcat LFBind l2) -> lin2string l1 `T.append` lin2string l2 Concat l1 (Concat Bind l2) -> lin2string l1 `T.append` lin2string l2
LFConcat l1 (LFConcat LFSpace l2) -> lin2string $ LFConcat l1 l2 Concat l1 (Concat Space l2) -> lin2string $ Concat l1 l2
LFConcat LFCapit l2 -> let l = lin2string l2 in T.toUpper (T.take 1 l) `T.append` T.drop 1 l Concat Capit l2 -> let l = lin2string l2 in T.toUpper (T.take 1 l) `T.append` T.drop 1 l
LFConcat LFAllCapit l2 -> let tks = T.words (lin2string l2) in T.unwords $ T.toUpper (head tks) : tail tks Concat AllCapit l2 -> let tks = T.words (lin2string l2) in T.unwords $ T.toUpper (head tks) : tail tks
LFConcat l1 l2 -> T.unwords $ filter (not.T.null) [lin2string l1, lin2string l2] Concat l1 l2 -> T.unwords $ filter (not.T.null) [lin2string l1, lin2string l2]
x -> T.pack $ printf "[%s]" (show x) x -> T.pack $ printf "[%s]" (show x)
-- | List indexing with more verbose error messages -- | List indexing with more verbose error messages
@@ -228,19 +234,19 @@ lin2string l = case l of
| i > length xs - 1 = error $ printf "!!: index %d too large for list: %s" i (show xs) | i > length xs - 1 = error $ printf "!!: index %d too large for list: %s" i (show xs)
| otherwise = xs Prelude.!! i | otherwise = xs Prelude.!! i
isInt :: LinFun -> Bool isIx :: LinFun -> Bool
isInt (LFInt _) = True isIx (Ix _) = True
isInt _ = False isIx _ = False
-- | Helper for building concat trees -- | Helper for building concat trees
mkConcat :: [LinFun] -> LinFun mkConcat :: [LinFun] -> LinFun
mkConcat [] = LFEmpty mkConcat [] = Empty
mkConcat [x] = x mkConcat [x] = x
mkConcat xs = foldl1 LFConcat xs mkConcat xs = foldl1 Concat xs
-- | Helper for unfolding concat trees -- | Helper for unfolding concat trees
unConcat :: LinFun -> [LinFun] unConcat :: LinFun -> [LinFun]
unConcat (LFConcat l1 l2) = concatMap unConcat [l1, l2] unConcat (Concat l1 l2) = concatMap unConcat [l1, l2]
unConcat lf = [lf] unConcat lf = [lf]
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
@@ -268,24 +274,24 @@ instance PP LinFun where
pp = pp' 0 pp = pp' 0
where where
pp' n = \case pp' n = \case
LFPre ps d -> do Pre ps d -> do
p "LFPre" p "Pre"
CMW.tell [ T.replicate (n+1) " " `T.append` T.pack (show p) | p <- ps ] CMW.tell [ T.replicate (n+1) " " `T.append` T.pack (show p) | p <- ps ]
pp' (n+1) d pp' (n+1) d
c@(LFConcat l1 l2) -> do c@(Concat l1 l2) -> do
let ts = unConcat c let ts = unConcat c
if any isDeep ts if any isDeep ts
then do then do
p "LFConcat" p "Concat"
mapM_ (pp' (n+1)) ts mapM_ (pp' (n+1)) ts
else else
ps $ "LFConcat " ++ show ts ps $ "Concat " ++ show ts
LFTuple ls | any isDeep ls -> do Tuple ls | any isDeep ls -> do
p "LFTuple" p "Tuple"
mapM_ (pp' (n+1)) ls mapM_ (pp' (n+1)) ls
LFProjection l1 l2 | isDeep l1 || isDeep l2 -> do Projection l1 l2 | isDeep l1 || isDeep l2 -> do
p "LFProjection" p "Projection"
pp' (n+1) l1 pp' (n+1) l1
pp' (n+1) l2 pp' (n+1) l2
t -> ps $ show t t -> ps $ show t
@@ -297,8 +303,8 @@ instance PP LinFun where
isDeep = not . isTerm isDeep = not . isTerm
isTerm = \case isTerm = \case
LFPre _ _ -> False Pre _ _ -> False
LFConcat _ _ -> False Concat _ _ -> False
LFTuple _ -> False Tuple _ -> False
LFProjection _ _ -> False Projection _ _ -> False
_ -> True _ -> True

2
testsuite/lpgf/unittests/Tables.gf
View File

@@ -1,6 +1,6 @@
abstract Tables = { abstract Tables = {
cat S ; F ; cat S ; F ;
fun fun
FtoS : F -> S ; FtoS, FtoS2 : F -> S ;
f1, f2, f3, f4, f5, f6 : F ; f1, f2, f3, f4, f5, f6 : F ;
} }

18
testsuite/lpgf/unittests/Tables.treebank
View File

@@ -15,3 +15,21 @@ TablesCnc: _ Q2
Tables: FtoS f6 Tables: FtoS f6
TablesCnc: R2 Q3 TablesCnc: R2 Q3
Tables: FtoS2 f1
TablesCnc: _ _
Tables: FtoS2 f2
TablesCnc: _ Q2
Tables: FtoS2 f3
TablesCnc: R2 Q3
Tables: FtoS2 f4
TablesCnc: _ _
Tables: FtoS2 f5
TablesCnc: _ Q2
Tables: FtoS2 f6
TablesCnc: R2 Q3

1
testsuite/lpgf/unittests/TablesCnc.gf
View File

@@ -16,6 +16,7 @@ concrete TablesCnc of Tables = {
f6 = { pr = { r = R2; q = Q3 } } ; f6 = { pr = { r = R2; q = Q3 } } ;
FtoS f = tbl ! f.pr ; FtoS f = tbl ! f.pr ;
FtoS2 f = tbl ! { r = R2 ; q = f.pr.q } ;
oper oper
tbl = table { tbl = table {
{ r = R1 ; q = _ } => "R1 _" ; { r = R1 ; q = _ } => "R1 _" ;