murder 1.0 → 1.1

raw patch · 6 files changed

+110/−12 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• examples/LangDef.hs +2/−2
• murder.cabal +3/−2
• src/Language/Grammars/Grammar.hs +6/−1
• src/Language/Grammars/Murder.hs +60/−1
• src/Language/Grammars/Murder/Derive.hs +29/−0
• src/Language/Grammars/Murder/UUParsing.hs +10/−6

@@ -29,10 +29,10 @@                                       <|>                                        (iI semAdd exp "+" term Ii)                                       <|> -                                      iI id term Ii +                                      iI term Ii                   term    <- addNT -<  (iI semMul term  "*"  factor Ii)                                       <|>-                                      iI id factor Ii+                                      iI factor Ii                  factor  <- addNT -<  (iI semCst int Ii)                                       <|>                                        (iI semVar var Ii)

@@ -1,5 +1,5 @@ name:               murder -version:            1.0+version:            1.1 cabal-version:      >= 1.2.3   license:            LGPL license-file:       COPYRIGHT@@ -17,6 +17,7 @@                             uulib>=0.9.12, uu-parsinglib >= 2.7.1, ListLike >= 3.1.0, containers>=0.3, HList>=0.2         exposed-modules:    Language.Grammars.Grammar,                              Language.Grammars.Murder, +                            Language.Grammars.Murder.Derive,                              Language.Grammars.Murder.Scanner,                             Language.Grammars.Murder.UUParsing,                             Language.Grammars.Murder.UULib@@ -31,7 +32,7 @@                             Language.Grammars.Transformations.LeftCorner         extensions:         EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies,                             MultiParamTypeClasses, RankNTypes, ScopedTypeVariables,-                            TypeSynonymInstances, UndecidableInstances, GADTs+                            TypeSynonymInstances, UndecidableInstances, GADTs, TemplateHaskell         hs-source-dirs:     src         ghc-options:        -Wall 

@@ -58,9 +58,14 @@  data Pos  =  Pos      !Line !Column            |  PosFile  !Line !Column Filename-  deriving Show+  deriving (Show,Eq) + data DTerm a = DTerm {pos :: Pos, value :: a}+  deriving (Show, Eq)++mkDTerm :: a -> DTerm a+mkDTerm v = DTerm (Pos 0 0) v  data TTerm data TNonT

@@ -38,6 +38,21 @@       updateFinalEnv  -<           updateEnv (\ps -> PS $ (unPP prds) ++ (unPS ps)) (getRefNT nont) +-- update the productions of an existing non-terminal+updProds  ::  PreGramTrafo  env +                         (Symbol a TNonT env, PreProductions TL env a -> PreProductions TL env a) ()+updProds  = proc (nont,f) -> do+      updateFinalEnv  -< +         updateEnv (\ps -> PS $ (unPP . f) (PP $ unPS ps)) (getRefNT nont)+++-- replace the productions of an existing non-terminal+replaceProds  ::  PreGramTrafo  env +                         (Symbol a TNonT env, PreProductions TL env a) ()+replaceProds  = proc (nont, prds) -> do+      updateFinalEnv  -< +         updateEnv (\_ -> PS $ (unPP prds)) (getRefNT nont)+   -- close the grammar closeGram :: (forall env. ExtGram  env a nts) @@ -53,6 +68,7 @@                 -> ExtGram env start' nts' extendGram g sm = g >>> sm +infixl 1 +>>  (+>>)      ::  (NTRecord (nts env), NTRecord (nts' env))               =>  ExtGram env start nts @@ -111,7 +127,7 @@ (^|) :: NTRecord (NTCons nt a l env) => LSPair nt a TNonT env -> l env -> NTCons nt a l env (^|) = NTCons -+{- class GetNT nt r v | nt r -> v where   getNT :: nt -> r -> v @@ -126,6 +142,49 @@  instance GetNT nt (nts env) r => GetNT nt (Export start nts env) r where  getNT nont  (Export _ nts)  = getNT nont nts+-}++class TypeEq x y b | x y -> b+instance TypeEq x x HTrue+instance HFalse ~ b => TypeEq x y b++data HTrue+data HFalse++typeEq :: TypeEq x y b => x -> y -> b+typeEq _ _ = undefined++++class GetNT nt r v | nt r -> v where+  getNT :: nt -> r -> v++instance GetNTLabel nt (nts env) (Symbol a TNonT env) (nts env) => GetNT nt (Export start nts env) (Symbol a TNonT env) where+ getNT nont  (Export _ nts)  = getNTLabel (undefined :: nts env) nont nts+++class GetNTLabel nt r v tenv | nt r -> v where+  getNTLabel :: tenv -> nt -> r -> v++class GetNTBool b nt r v tenv | b nt r -> v where+  getNTBool :: b -> tenv -> nt -> r -> v+++data NotFound nt tenv++instance Fail (NotFound nt (tenv env)) => GetNTLabel nt (NTNil env) r (tenv env) where+ getNTLabel = undefined++instance (TypeEq nt1 nt2 b, GetNTBool b nt1 (NTCons nt2 v l env) r (tenv env)) => GetNTLabel nt1 (NTCons nt2 v l env) r (tenv env) where+ getNTLabel t nt1  l@(NTCons nt2 _)    = getNTBool (typeEq nt1 (labelLSPair nt2)) t nt1 l+++instance GetNTBool HTrue nt1  (NTCons nt1 v l env) (Symbol v TNonT env) (tenv env) where + getNTBool _ _ _     (NTCons f _)    = symLSPair f++instance GetNTLabel nt1 (l env) r (tenv env) => GetNTBool HFalse nt1 (NTCons nt2 v l env) r (tenv env) where+ getNTBool _ t nont  (NTCons _ l)    = getNTLabel t nont l+  getStart :: Export start nts env ->  (Symbol start TNonT env) getStart (Export start _) = start

@@ -0,0 +1,29 @@+{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-}++module Language.Grammars.Murder.Derive (csLabel, csLabels) where++import Language.Haskell.TH+import Control.Monad++declareLabel :: Name -> Name -> TypeQ -> Q [Dec]+declareLabel ndata nlabel t = do +            dtl <- dataD (cxt []) ndata [] [] []+            lbl <- declareFnLabel nlabel t+            return $ dtl:lbl++declareFnLabel ::  Name -> TypeQ -> Q [Dec]+declareFnLabel nlabel t = do +            sgn <- sigD nlabel t  +            let pxy = normalB [| undefined |]+            lbl <- funD nlabel [clause [] pxy []]+            return [sgn,lbl]++csLabel ::  String -> Q [Dec]+csLabel nt = declareLabel ntTn ntn  (conT $ ntTn) +  where+      ntn   = mkName nt+      ntTn  = mkName $ "Cs_" ++ nt++csLabels ::  [String] -> Q [Dec]+csLabels = liftM concat . mapM csLabel+

@@ -37,6 +37,10 @@ lc2Pos :: LineCol -> Pos lc2Pos (LineCol l c) = Pos l c +incPos :: Pos -> Pos+incPos (Pos     l c  ) = Pos     (l+1) (c+1)+incPos (PosFile l c f) = PosFile (l+1) (c+1) f+       newtype Const f a s = C {unC :: f a}  -- | The function 'compile' generates a parser out of a closed grammar @@ -54,14 +58,14 @@          comp (FlipStar x y)   = comp x <**>  comp y          comp (Pure     x)     = pure x -         comp (Sym (Term t))   = (DTerm . lc2Pos) <$> pPos <*> pTerm t+         comp (Sym (Term t))   = (DTerm . incPos . lc2Pos) <$> pPos <*> pTerm t          comp (Sym (Nont n))   = unC (lookupEnv n result) -         comp (Sym TermInt)    = (DTerm . lc2Pos) <$> pPos <*> pInt-         comp (Sym TermChar)   = (DTerm . lc2Pos) <$> pPos <*> pChr-         comp (Sym TermVarid)  = (DTerm . lc2Pos) <$> pPos <*> pVar-         comp (Sym TermConid)  = (DTerm . lc2Pos) <$> pPos <*> pCon-         comp (Sym TermOp)     = (DTerm . lc2Pos) <$> pPos <*> pOp+         comp (Sym TermInt)    = (DTerm . incPos . lc2Pos) <$> pPos <*> pInt+         comp (Sym TermChar)   = (DTerm . incPos . lc2Pos) <$> pPos <*> pChr+         comp (Sym TermVarid)  = (DTerm . incPos . lc2Pos) <$> pPos <*> pVar+         comp (Sym TermConid)  = (DTerm . incPos . lc2Pos) <$> pPos <*> pCon+         comp (Sym TermOp)     = (DTerm . incPos . lc2Pos) <$> pPos <*> pOp   mapEnv  ::  (forall a . f a s -> g a s)