imparse 0.0.0.1 → 0.0.0.2
raw patch · 6 files changed
+1170/−2 lines, 6 files
Files
- Text/Imparse/AbstractSyntax.hs +222/−0
- Text/Imparse/Analysis.hs +349/−0
- Text/Imparse/Compile/Haskell.hs +393/−0
- Text/Imparse/Parse.hs +110/−0
- Text/Imparse/Report.hs +89/−0
- imparse.cabal +7/−2
+ Text/Imparse/AbstractSyntax.hs view
@@ -0,0 +1,222 @@+---------------------------------------------------------------- +-- +-- Imparse +-- +-- Text/Imparse/AbstractSyntax.hs +-- Data structure for Imparse parser definitions. +-- + +---------------------------------------------------------------- +-- + +module Text.Imparse.AbstractSyntax + where + +import Data.String.Utils (join) +import Data.List (nub) + +import qualified Text.RichReports as R +import qualified Text.UxADT as U +import qualified StaticAnalysis.All as A + +---------------------------------------------------------------- +-- Parser data structure. + +type Import = String +type NonTerminal = String +type Constructor = String +type WhitespaceParse = Bool + +data Parser a = + Parser a [Import] [Production a] + deriving Eq + +data Production a = + Production a NonTerminal [Choices a] + deriving Eq + +data Choices a = + Choices a [Choice a] + deriving Eq + +data Choice a = + Choice a (Maybe Constructor) Association [Element a] + deriving Eq + +type Minimum = Integer +type Separator = String +type TerminalString = String +type RegularExpression = String + +data Association = + AssocNone + | AssocRight + | AssocLeft + | AssocFlat + deriving Eq + +data Element a = + NonTerminal a NonTerminal + | Many (Element a) (Maybe Separator) + | May (Element a) + | Indented WhitespaceParse (Element a) + | Terminal Terminal + | Error String + deriving Eq + +data Terminal = + Explicit String + | StringLiteral + | NaturalLiteral + | DecimalLiteral + | Identifier + | Constructor + | Flag + | RegExp RegularExpression + deriving Eq + +---------------------------------------------------------------- +-- Static analysis annotation setting and retrieval. + +instance A.Annotated Parser where + annotate (Parser _ ms ps) a = Parser a ms ps + annotation (Parser a ms ps) = a + +instance A.Annotated Production where + annotate (Production _ e css) a = Production a e css + annotation (Production a _ _) = a + +instance A.Annotated Choices where + annotate (Choices _ cs) a = Choices a cs + annotation (Choices a _) = a + +instance A.Annotated Choice where + annotate (Choice _ mc asc es) a = Choice a mc asc es + annotation (Choice a _ _ _) = a + +instance A.Annotated Element where + annotate e a = case e of + NonTerminal _ e -> NonTerminal a e + Many e ms -> Many (A.annotate e a) ms + May e -> May (A.annotate e a) + Indented w e -> Indented w $ A.annotate e a + _ -> e + annotation e = case e of + NonTerminal a _ -> a + Many e _ -> A.annotation e + May e -> A.annotation e + Indented w e -> A.annotation e + _ -> A.unanalyzed + +---------------------------------------------------------------- +-- Functions for inspecting parser instances. + +isData :: Element a -> Bool +isData e = case e of + NonTerminal _ _ -> True + Many _ _ -> True + May _ -> True + Indented _ _ -> True + Terminal StringLiteral -> True + Terminal NaturalLiteral -> True + Terminal DecimalLiteral -> True + Terminal Identifier -> True + Terminal Constructor -> True + Terminal Flag -> True + Terminal (RegExp _) -> True + _ -> False + +terminals :: Parser a -> [Terminal] +terminals (Parser _ _ ps) = + nub $ + [t | Production _ e css <- ps, Choices _ cs <- css, Choice _ _ _ es <- cs, Terminal t <- es] + +productionNonTerminal :: Production a -> NonTerminal +productionNonTerminal (Production _ nt _) = nt + +---------------------------------------------------------------- +-- Functions for converting a parser into a UXADT instance string. + +instance U.ToUxADT (Parser a) where + uxadt (p@(Parser _ _ ps)) = + U.C "Parser" [ + U.C "Productions" [U.L [U.uxadt p | p <- ps]], + U.C "Terminals" [U.L [U.uxadt t | t <- terminals p]] + ] + +instance U.ToUxADT (Production a) where + uxadt (Production _ en css) = U.C "Production" [U.S en, U.uxadt css] + +instance U.ToUxADT (Choices a) where + uxadt (Choices _ cs) = U.C "Choices" [U.uxadt c | c <- cs] + +instance U.ToUxADT (Choice a) where + uxadt (Choice _ c _ es) = U.C "Choice" [maybe U.None U.S c, U.uxadt es] + +instance U.ToUxADT (Element a) where + uxadt e = case e of + NonTerminal _ n -> U.C "NonTerminal" [U.S n] + Many e ms -> U.C "Many" $ [U.uxadt e] ++ maybe [] (\s -> [U.S s]) ms + May e -> U.C "May" [U.uxadt e] + Indented w e -> U.C "Indented" [U.uxadt w, U.uxadt e] + Terminal t -> U.C "Terminal" [U.uxadt t] + Error s -> U.C "Error" [U.S s] + +instance U.ToUxADT Terminal where + uxadt t = case t of + Explicit s -> U.C "Explicit" [U.S s] + StringLiteral -> U.C "StringLiteral" [] + NaturalLiteral -> U.C "NaturalLiteral" [] + DecimalLiteral -> U.C "DecimalLiteral" [] + Identifier -> U.C "Identifier" [] + Constructor -> U.C "Constructor" [] + Flag -> U.C "Flag" [] + RegExp r -> U.C "RegExp" [U.S r] + +---------------------------------------------------------------- +-- Functions for converting a parser into an ASCII string. + +instance Show (Parser a) where + show (Parser _ _ ps) = join "\n\n" (map show ps) ++ "\n" + +instance Show (Production a) where + show (Production a en css) = + en ++ " ::=\n " ++ join "\n ^\n " [show cs | cs <- css] + +instance Show (Choices a) where + show (Choices a cs) = join "\n " $ map show cs + +instance Show (Choice a) where + show (Choice a c assoc es) = + (maybe "" id c) ++ " " ++ show assoc ++ " " ++ (join " " $ map show es) + +instance Show Association where + show a = case a of + AssocNone -> "|" + AssocRight -> ">" + AssocLeft -> "<" + AssocFlat -> "~" + +instance Show (Element a) where + show (Terminal t) = show t + show (Error s) = "`!!!_" ++ s ++ "_!!!" + show e = + let rec e = case e of + NonTerminal _ nt -> nt + Many e ms -> "[" ++ rec e ++ (maybe "" (\s->"/" ++ show s) ms) ++ "]" + May e -> "(" ++ rec e ++ ")" + Indented w e -> if w then ">>" ++ rec e ++ "<<" else ">" ++ rec e ++ "<" + in "`" ++ rec e + +instance Show Terminal where + show t = case t of + Explicit s -> s + StringLiteral -> "`$" + NaturalLiteral -> "`#" + DecimalLiteral -> "`#.#" + Identifier -> "`id" + Constructor -> "`con" + Flag -> "`flag" + RegExp r -> "`{" ++ r ++ "}" + +--eof
+ Text/Imparse/Analysis.hs view
@@ -0,0 +1,349 @@+---------------------------------------------------------------- +-- +-- Imparse +-- +-- Text/Imparse/Analysis.hs +-- Analyzer/validator for Imparse parsers. +-- + +---------------------------------------------------------------- +-- + +module Text.Imparse.Analysis + where + +import Data.List (nub, intersect) +import Data.Maybe (isJust) +import qualified Data.Map as Map (fromListWith, lookup, Map) + +import qualified Text.RichReports as R +import qualified StaticAnalysis.All as S + +import qualified Text.Imparse.AbstractSyntax as A +import Text.Imparse.Report + +---------------------------------------------------------------- +-- Analysis data structure, instance declarations, accessors, +-- and mutators. + +type InitialNonTerminals = [A.NonTerminal] +type InitialTerminals = [A.Terminal] +type ReachableNonTerminals = [A.NonTerminal] +type Characterization = (InitialTerminals, InitialNonTerminals, ReachableNonTerminals) + +data Analysis = + Analyzed [Tag] Characterization + deriving (Eq, Show) + +data Tag = + GrammarRecursive + | GrammarNonRecursive + | GrammarLinear + | GrammarLeftLinear + | GrammarRightLinear + | GrammarCFG + | ProductionBase + | ProductionNonRecursive + | ProductionRecursive + | ProductionInfixPrefixThenDeterministic + | ProductionDeterministic + | ProductionDuplicate + | ProductionUnreachable + | ChoicesBase + | ChoicesDeterministic + | ChoicesNonRecursive + | ChoicesRecursive + | ChoicesRecursivePrefixInfix + | ChoiceBase + | ChoiceNonRecursive + | ChoiceRecursive + | ChoiceRecursivePrefix + | ChoiceRecursiveInfix + | ChoiceIndentedSuffix + | ChoiceConstructorDuplicate + | NonTerminalUnbound + deriving (Eq, Show) + +instance S.Analysis Analysis where + unanalyzed = Analyzed [] ([], [], []) + +tag :: Analysis -> [Tag] -> Analysis +tag a ts' = case a of + Analyzed ts c -> Analyzed (nub $ ts' ++ ts) c + +tags :: S.Annotated a => a Analysis -> [Tag] +tags d = let Analyzed ts _ = S.annotation d in ts + +initialTerminals :: S.Annotated a => a Analysis -> InitialTerminals +initialTerminals d = let Analyzed _ (ts, _, _) = S.annotation d in ts + +initialNonTerminals :: S.Annotated a => a Analysis -> InitialNonTerminals +initialNonTerminals d = let Analyzed _ (_, ns, _) = S.annotation d in ns + +reachable :: S.Annotated a => a Analysis -> ReachableNonTerminals +reachable d = let Analyzed _ (_, _, rns) = S.annotation d in rns + +characterization :: S.Annotated a => a Analysis -> Characterization +characterization d = let Analyzed _ c = S.annotation d in c + +combine :: [Characterization] -> Characterization +combine c = (nub $ concat x, nub $ concat y, nub $ concat z) where (x,y,z) = unzip3 c + +mapCmb :: (a -> (a, Characterization)) -> [a] -> ([a], Characterization) +mapCmb f xs = let (xs', cs) = unzip $ map f xs in (xs', combine cs) + +---------------------------------------------------------------- +-- Reporting of analysis results. + +instance R.ToMessages Analysis where + messages a = case a of + Analyzed [] ([], [], [] ) -> [R.Text "Unanalyzed."] + Analyzed tags (ts, ns, rns) -> [ + R.Table [ + R.Row [ R.Field (R.Text "term.:"), R.Field (R.Intersperse (R.Text ",") $ map R.report ts) ], + R.Row [ R.Field (R.Text "non-term.:"), R.Field (R.Intersperse (R.Text ",") $ map R.Text ns) ], + R.Row [ R.Field (R.Text "reach.:"), R.Field (R.Intersperse (R.Text ",") $ map R.Text rns) ], + R.Row [ R.Field (R.Text "prop.:"), R.Field (R.Intersperse (R.Text ",") $ concat $ map R.messages tags) ] + ] + ] + +instance R.ToHighlights Analysis where + highlights a = case a of + Analyzed [] ([], [], []) -> [R.HighlightError] + Analyzed tags c -> concat $ map R.highlights tags + +instance R.ToMessages Tag where + messages t = case t of + ProductionBase -> [R.Text "Base"] + ProductionNonRecursive -> [R.Text "NonRecursive"] + ProductionRecursive -> [R.Text "Recursive"] + ProductionInfixPrefixThenDeterministic -> [R.Text "InfixPrefixThenDeterministic"] + ProductionDeterministic -> [R.Text "Deterministic"] + ProductionDuplicate -> [R.Text "Duplicate"] + ProductionUnreachable -> [R.Text "Unreachable"] + ChoicesBase -> [R.Text "Base"] + ChoicesDeterministic -> [R.Text "Deterministic"] + ChoicesNonRecursive -> [R.Text "NonRecursive"] + ChoicesRecursive -> [R.Text "Recursive"] + ChoicesRecursivePrefixInfix -> [R.Text "RecursivePrefixInfix"] + ChoiceBase -> [R.Text "Base"] + ChoiceNonRecursive -> [R.Text "NonRecursive"] + ChoiceRecursive -> [R.Text "Recursive"] + ChoiceRecursivePrefix -> [R.Text "RecursivePrefix"] + ChoiceRecursiveInfix -> [R.Text "RecursiveInfix"] + ChoiceIndentedSuffix -> [R.Text "IndentedSuffix"] + ChoiceConstructorDuplicate -> [R.Text "ConstructorDuplicate"] + NonTerminalUnbound -> [R.Text "Unbound"] + _ -> [] + +instance R.ToHighlights Tag where + highlights t = case t of + NonTerminalUnbound -> [R.HighlightUnbound] + ProductionDuplicate -> [R.HighlightDuplicate] + ProductionUnreachable -> [R.HighlightUnreachable] + ChoiceConstructorDuplicate -> [R.HighlightError] + _ -> [] + +---------------------------------------------------------------- +-- Baseline analysis (initial non-/terminals and reachable +-- non-terminals) and its closure (fully recursive +-- characterization of initial and reachable non-/terminals). + +baseline :: A.Parser Analysis -> A.Parser Analysis +baseline (A.Parser a ims ps) = A.Parser (Analyzed [] r) ims ps' where + (ps', r) = mapCmb production ps + + production (A.Production _ e css) = (A.Production (Analyzed [] r) e css', r) + where (css', r) = mapCmb choices css + + choices (A.Choices _ cs) = (A.Choices (Analyzed [] r) cs', r) + where (cs', r) = mapCmb choice cs + + choice (A.Choice _ mc asc (es@(e:_))) = (A.Choice (Analyzed [] r) mc asc es, r) + where r = (nub $ terminals e, nub $ nonterminals e, nub $ concat $ map reachable es) + + terminals e = case e of A.Terminal t -> [t] ; _ -> [] + + nonterminals e = case e of + A.NonTerminal _ e -> [e] + A.Many e ms -> nonterminals e + A.May e -> nonterminals e + _ -> [] + + reachable e = case e of + A.NonTerminal _ e -> [e] + A.Many e ms -> reachable e + A.May e -> reachable e + A.Indented w e -> reachable e + _ -> [] + +closure :: A.Parser Analysis -> A.Parser Analysis +closure (A.Parser a ims ps) = A.Parser a ims ps'' where + ps'' = + [ A.Production a e + [ let cs' = + [ let es' = + [ let sub e = case e of + A.NonTerminal _ e -> + A.NonTerminal ( + let l = concat $ map (lookP e) ps' + in if length l > 0 then (Analyzed [] (head l)) else S.unanalyzed + ) + e + A.Many e ms -> A.Many (sub e) ms + A.May e -> A.May (sub e) + A.Indented w e -> A.Indented w (sub e) + _ -> e + in sub e + | e <- es + ] + (ts', ns', _) = characterization (head es') + rs' = concat $ map reachable es' + in A.Choice (Analyzed [] (nub $ ts'++ts, nub $ ns'++ns, nub $ rs'++rs)) con asc es' + | A.Choice (Analyzed _ (ts, ns, rs)) con asc es <- cs + ] + in A.Choices (Analyzed [] (combine $ [c] ++ map characterization cs')) cs' + | A.Choices (Analyzed _ c) cs <- css + ] + | A.Production a e css <- ps' + ] + ps' = (foldr (.) id $ take (length ps) $ repeat step) ps + step ps = + [ let (_, _ , rss') = unzip3 $ map (look rs) ps + (_, nss', _ ) = unzip3 $ map (look ns) ps + (ns', rs') = (concat nss', concat rss') + ts' = nub $ (ts ++ concat (map (lookTs (ns ++ ns')) ps)) + in A.Production (Analyzed tags (ts', nub $ ns ++ ns', nub $ rs ++ rs')) e css + | A.Production (Analyzed tags (ts, ns, rs)) e css <- ps + ] + look es (A.Production (Analyzed _ c) e _) = if e `elem` es then c else ([], [], []) + lookTs es (A.Production (Analyzed _ (ts, ns, rs)) e _) = if e `elem` es then ts else [] + lookP e' (A.Production (Analyzed _ c) e _) = if e == e' then [c] else [] + +---------------------------------------------------------------- +-- Property derivation and tagging algorithms. + +tagging :: A.Parser Analysis -> A.Parser Analysis +tagging (A.Parser a ims ps) = A.Parser a ims (map production ps) where + production (A.Production a e css) = A.Production (tag a ts) e css' + where + css' = map (choices e) css + ts = (if and [ChoicesBase `elem` tags cs | cs <- css'] then [ProductionBase] else []) + ++ (if and [ChoicesNonRecursive `elem` tags cs | cs <- css'] then [ProductionNonRecursive] else []) + ++ (if or [ChoicesRecursive `elem` tags cs | cs <- css'] then [ProductionRecursive] else []) + ++ (if or [ChoicesRecursive `elem` tags cs | cs <- css'] then [ProductionRecursive] else []) + ++ (let pat [ts] = ChoicesDeterministic `elem` ts || ChoicesNonRecursive `elem` ts + pat (ts:tss) = ChoicesRecursivePrefixInfix `elem` ts && pat tss + in if length css' > 1 && pat [tags cs | cs <- css'] then [ProductionInfixPrefixThenDeterministic] else [] + ) + + choices e (cc@(A.Choices a cs)) = A.Choices (tag a ts) cs' + where + cs' = map (choice e) cs + ts = (if and [ChoiceBase `elem` tags c | c <- cs'] then [ChoicesBase] else []) + ++ [if e `elem` reachable cc then ChoicesRecursive else ChoicesNonRecursive] + ++ (if and [initialTerminals (cs'!!i) `intersect` initialTerminals (cs'!!j) == [] | i <- [0..length cs'-1], j <- [0..i-1]] then + [ChoicesDeterministic] + else + [] + ) + ++ (if and [ChoiceRecursivePrefix `elem` tags c || ChoiceRecursiveInfix `elem` tags c | c <- cs'] then + [ChoicesRecursivePrefixInfix] + else + [] + ) + + choice e (c@(A.Choice a mc asc es)) = A.Choice (tag a ts') mc asc es + where + ts' = (if length es == length [e | e@(A.Terminal _) <- es] then [ChoiceBase] else []) + ++ [if e `elem` reachable c then ChoiceRecursive else ChoiceNonRecursive] + ++ (case es of + [A.Terminal (A.Explicit _), A.NonTerminal _ nt] -> + if nt == e && isJust mc then [ChoiceRecursivePrefix] else [] + [A.NonTerminal _ nt1, A.Terminal (A.Explicit _), A.NonTerminal _ nt2] -> + if nt1 == e && nt2 == e && isJust mc then [ChoiceRecursiveInfix] else [] + _ -> [] + ) + ++ (let chkTerm e = case e of A.Terminal _ -> True ; _ -> False + chkNotIndented e = case e of A.Indented _ _ -> False ; _ -> True + chkLast e = case e of A.Indented True (A.Many _ _) -> True ; _ -> False + in if ( length es > 1 + && and (map chkNotIndented (init es)) + && or (map chkTerm (init es)) + && chkLast (last es) + ) then + [ChoiceIndentedSuffix] + else + [] + ) + +analyze :: A.Parser Analysis -> A.Parser Analysis +analyze parser = + let + (A.Parser a ims ps) = tagging $ closure $ baseline parser + + productions :: [A.Production Analysis] -> [A.Production Analysis] + productions ps = + let es = [e | A.Production _ e _ <- ps] + in + [ A.Production a e [A.Choices a (map (choice es) cs) | A.Choices a cs <- css] + | A.Production a e css <- ps + ] + + choice :: [A.NonTerminal] -> A.Choice Analysis -> A.Choice Analysis + choice es (A.Choice a c asc es') = A.Choice a c asc (map (element es) es') + + element es e = case e of + A.NonTerminal a e -> A.NonTerminal (tag a $ if e `elem` es then [] else [NonTerminalUnbound]) e + A.Many e s -> A.Many (element es e) s + A.May e -> A.May (element es e) + A.Indented w e -> A.Indented w (element es e) + _ -> e + + -- Check for duplicate productions non-terminal names. + m = Map.fromListWith (+) [(e,1) | A.Production _ e _ <- ps] + chkDups top e = (case Map.lookup e m of Just n -> if n > 1 then [ProductionDuplicate] else [] ; _ -> []) + ++ (if not (e `elem` reachable top) && (e /= A.productionNonTerminal top) then [ProductionUnreachable] else []) + ps' = [A.Production (tag a (chkDups (head ps) e)) e cs | A.Production a e cs <- ps] + + -- Check for duplicate choice constructors. + conMap = Map.fromListWith (+) [(c,1) | A.Production _ _ css <- ps', A.Choices _ cs <- css, A.Choice _ (Just c) _ _ <- cs] + chkConDup c = case c of + Nothing -> [] + Just c -> case Map.lookup c conMap of Just n -> if n > 1 then [ChoiceConstructorDuplicate] else [] ; _ -> [] + ps'' = + [ A.Production a e + [ A.Choices a' + [A.Choice (tag a'' (chkConDup con)) con asc es + | A.Choice a'' con asc es <- cs + ] + | A.Choices a' cs <- css + ] + | A.Production a e css <- ps' + ] + + -- Mark unbound entities within the production bodies. + ps''' = productions ps'' + + in A.Parser a ims ps''' + +---------------------------------------------------------------- +-- Other useful functions. + +infixPrefixOps :: A.Parser Analysis -> [String] +infixPrefixOps (A.Parser _ _ ps) = + nub $ + [op | + A.Production _ e css <- ps, + A.Choices _ cs <- css, + c@(A.Choice _ _ _ [A.Terminal (A.Explicit op), A.NonTerminal _ nt]) <- cs, + ChoiceRecursivePrefix `elem` tags c + ] + ++ [op | + A.Production _ e css <- ps, + A.Choices _ cs <- css, + c@(A.Choice _ _ _ [A.NonTerminal _ nt1, A.Terminal (A.Explicit op), A.NonTerminal _ nt2]) <- cs, + ChoiceRecursiveInfix `elem` tags c + ] + +--eof
+ Text/Imparse/Compile/Haskell.hs view
@@ -0,0 +1,393 @@+---------------------------------------------------------------- +-- +-- Imparse +-- +-- Text/Imparse/Compile/Haskell.hs +-- Compilation from an Imparse parser definition to a Haskell +-- implementation of a abstract syntax data type and Parsec +-- parser. +-- + +---------------------------------------------------------------- +-- + +module Text.Imparse.Compile.Haskell + where + +import Data.Char (toLower) +import Data.List (nub, (\\)) +import Data.String.Utils (join, replace) +import Data.Maybe (catMaybes) +import Control.Compilation.Compile + +import Text.Imparse.AbstractSyntax +import qualified Text.Imparse.Analysis as S + +---------------------------------------------------------------- +-- Helper functions. + +toLowerFirst :: String -> String +toLowerFirst [] = [] +toLowerFirst (c:cs) = toLower c : cs + +---------------------------------------------------------------- +-- Compilation to abstract syntax data type definition. + +toAbstractSyntax :: String -> Parser a -> Compile String () +toAbstractSyntax prefix p = + do prefix <- return $ if prefix == "" then "" else prefix ++ "." + raw $ "-- This module generated automatically by imparse.\n\n" + raw $ "module " ++ prefix ++ "AbstractSyntax\n" + raw " where" + newlines 2 + toDatatype p + newline + raw "--eof" + +toDatatype :: Parser a -> Compile String () +toDatatype (Parser _ _ ps) = + let production :: Production a -> Compile String () + production (Production _ e css) = + do raw "data " + raw e + raw " = " + indent + newline + raw " " + choices $ concat [cs | Choices _ cs <- css] + raw "deriving (Show, Eq)" + unindent + newlines 2 + + choices :: [Choice a] -> Compile String () + choices cs = case cs of + [c] -> + do choice c + newline + c:cs -> + do choice c + newline + raw "| " + choices cs + + choice :: Choice a -> Compile String () + choice c = case c of + Choice _ con _ es -> + do con <- + case con of + Nothing -> do { c <- fresh; return $ "C" ++ c } + Just con -> return con + raw con + mapM element es + nothing + + element :: Element a -> Compile String () + element e = case e of + NonTerminal _ entity -> do { raw " "; raw entity } + Many e _ -> do { raw " ["; elementNoSp e; raw "]" } + May (Many e _) -> do { raw " ["; elementNoSp e; raw "]" } + May e -> do { raw " (Maybe "; elementNoSp e; raw ")" } + Indented w e -> element e + Terminal t -> do { raw " "; terminal t } + _ -> do nothing + + elementNoSp :: Element a -> Compile String () + elementNoSp e = case e of + NonTerminal _ entity -> do { raw entity } + Many e _ -> do { raw "["; element e; raw "]" } + May (Many e _) -> do { raw "["; element e; raw "]" } + May e -> do { raw "(Maybe "; elementNoSp e; raw ")" } + _ -> element e + + terminal :: Terminal -> Compile String () + terminal t = case t of + StringLiteral -> raw "String" + NaturalLiteral -> raw "Integer" + DecimalLiteral -> raw "Double" + Identifier -> raw "String" + Constructor -> raw "String" + Flag -> raw "String" + RegExp _ -> raw "String" + _ -> do nothing + + in do mapM production ps + nothing + +---------------------------------------------------------------- +-- Compilation to rich reporting instance declarations. + +toRichReport :: String -> Parser a -> Compile String () +toRichReport prefix p = + do raw $ "-- This module generated automatically by imparse.\n\n" + prefix <- return $ if prefix == "" then "" else prefix ++ "." + raw $ "module " ++ prefix ++ "Report" + newline + raw " where" + newlines 2 + raw "import qualified Text.RichReports as R" + newlines 2 + raw $ "import " ++ prefix ++ "AbstractSyntax" + newlines 2 + toReportFuns p + newline + raw "--eof" + +toReportFuns :: Parser a -> Compile String () +toReportFuns (Parser _ _ ps) = + let production :: Production a -> Compile String () + production (Production _ e css) = + do raw $ "instance R.ToReport " ++ e ++ " where" + indent + newline + raw "report x = case x of" + indent + newline + mapM choices css + unindent + unindent + newline + + choices :: Choices a -> Compile String () + choices (Choices a cs) = case cs of + [] -> do nothing + c:cs -> do { choice c; newline; choices (Choices a cs) } + + choice :: Choice a -> Compile String () + choice c = case c of + Choice _ con _ es -> + do con <- + case con of + Nothing -> do { c <- fresh; return $ "C" ++ c } + Just con -> return con + + ves <- return $ [("v" ++ show k, es!!k) | k <- [0..length es-1]] + raw $ con ++ " " ++ join " " [v | (v,e) <- ves, isData e] ++ " -> " + raw $ "R.Span [] [] $ [" ++ join ", " (catMaybes $ map element ves) ++ "]" + + element :: (String, Element a) -> Maybe String + element (v,e) = case e of + NonTerminal _ entity -> Just $ "R.report " ++ v + Many e' _ -> element (v,e') + May e' -> element (v,e') + Indented w (May (Many e' _)) -> + maybe Nothing (\r -> Just $ "R.BlockIndent [] [] $ [R.Line [] [R.report vx] | vx <- " ++ v ++ "]") $ element (v,e') + Indented w (Many e' _) -> + maybe Nothing (\r -> Just $ "R.BlockIndent [] [] $ [R.Line [] [R.report vx] | vx <- " ++ v ++ "]") $ element (v,e') + Indented w e' -> + maybe Nothing (\r -> Just $ "R.BlockIndent [] [] $ [" ++ r ++ "]") $ element (v,e') + Terminal t -> Just $ terminal v t + _ -> Nothing + + terminal :: String -> Terminal -> String + terminal v t = case t of + Explicit s -> "R.key \"" ++ s ++ "\"" + StringLiteral -> "R.lit " ++ v + NaturalLiteral -> "R.lit (show " ++ v ++ ")" + DecimalLiteral -> "R.lit " ++ v + Identifier -> "R.var " ++ v + Constructor -> "R.Text " ++ v + Flag -> "R.Text " ++ v + RegExp _ -> "R.Text " ++ v + + in do mapM production ps + nothing + +---------------------------------------------------------------- +-- Compilation to Parsec parser. + +toParsec :: String -> Parser S.Analysis -> Compile String () +toParsec prefix (p@(Parser _ _ ((Production _ eRoot _):_))) = + do raw $ "-- This module generated automatically by imparse.\n\n" + prefix <- return $ if prefix == "" then "" else prefix ++ "." + raw $ "module " ++ prefix ++ "Parse\n where\n" + newline + raw $ "import " ++ prefix ++ "AbstractSyntax" + newlines 2 + + reservedOpNames <- return $ nub $ S.infixPrefixOps p + opLetters <- return $ nub $ concat reservedOpNames + reservedNames <- return $ (nub [r | Explicit r <- terminals p]) \\ reservedOpNames + + raw "----------------------------------------------------------------\n-- Parser to convert concrete syntax to abstract syntax.\n\n" + raw "import Text.Parsec\n" + raw "import qualified Text.Parsec.Indent as PI (withBlock, runIndent)\n" + raw "import qualified Text.Parsec.Token as PT\n" + raw "import qualified Text.Parsec.Expr as PE\n" + raw "import qualified Text.ParserCombinators.Parsec.Language as PL\n" + raw "import qualified Text.ParserCombinators.Parsec.Prim as Prim\n\n" + raw "import Control.Monad.Trans.State.Lazy (StateT)\n" + raw "import Data.Functor.Identity (Identity)\n\n" + raw "----------------------------------------------------------------\n-- Parsing functions to export.\n\n" + raw $ "parseString :: String -> Either ParseError " ++ eRoot ++ "\n" + raw "parseString s = PI.runIndent \"\" $ runParserT root () \"\" s\n\n" + raw "----------------------------------------------------------------\n-- Parser state.\n\n" + raw "type ParseState = StateT SourcePos Identity\n" + raw "type ParseFor a = ParsecT [Char] () ParseState a\n\n" + raw "----------------------------------------------------------------\n-- Parsec-specific configuration definitions and synonyms.\n\n" + raw "langDef :: PL.GenLanguageDef String () ParseState\n" + raw "langDef = PL.javaStyle\n" + raw " { PL.identStart = oneOf \"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijkmlnopqrstuvwxyz_\" -- Only lowercase.\n" + raw " , PL.identLetter = alphaNum <|> oneOf \"_'\"\n" + raw " , PL.opStart = PL.opLetter langDef\n" + raw $ " , PL.opLetter = oneOf \"" ++ opLetters ++ "\"\n" + raw $ " , PL.reservedOpNames = [" ++ join "," ["\"" ++ rO ++ "\"" | rO <- reservedOpNames] ++ "]\n" + raw $ " , PL.reservedNames = [" ++ join "," ["\"" ++ rO ++ "\"" | rO <- reservedNames] ++ "]\n" + raw " , PL.commentLine = \"#\"\n" + raw " }\n\n" + raw "lang :: PT.GenTokenParser [Char] () ParseState\n" + raw "lang = PT.makeTokenParser langDef\n\n" + raw "whiteSpace = PT.whiteSpace lang\n" + raw "symbol = PT.symbol lang\n" + raw "rO = PT.reservedOp lang\n" + raw "res = PT.reserved lang\n" + raw "identifier = PT.identifier lang\n" + raw "natural = PT.natural lang\n\n" + raw "binary name f assoc = PE.Infix (do{PT.reservedOp lang name; return f}) assoc\n" + raw "prefix name f = PE.Prefix (do{PT.reservedOp lang name; return f})\n\n" + raw "withIndent p1 p2 f = PI.withBlock f p1 p2\n\n" + raw "con :: ParseFor String\n" + raw "con = do { c <- oneOf \"ABCDEFGHIJKLMNOPQRSTUVWXYZ\" ; cs <- option \"\" identifier ; return $ c:cs }\n\n" + raw "flag :: ParseFor String\n" + raw "flag = do { cs <- many1 (oneOf \"ABCDEFGHIJKLMNOPQRSTUVWXYZ\") ; return cs }\n" + raw "-- caps = do { cs <- many1 (oneOf \"ABCDEFGHIJKLMNOPQRSTUVWXYZ\") ; return cs }\n\n" + raw "(<?|>) p1 p2 = (try p1) <|> p2\n\n" + raw "----------------------------------------------------------------\n-- Parser definition.\n\n" + raw $ "root = do { whiteSpace ; r <- p" ++ eRoot ++ " ; eof ; return r }" + newlines 2 + toParsecDefs p + raw "--eof" + +toParsecDefs :: Parser S.Analysis -> Compile String () +toParsecDefs (Parser _ _ ps) = + let production :: Production S.Analysis -> Compile String () + production (p@(Production _ e css)) = + do raw $ "p" ++ e ++ " =" + ( if S.ProductionInfixPrefixThenDeterministic `elem` S.tags p then + do ops <- return $ join "," $ + [ "[" + ++ join "," + [ case es of + [Terminal (Explicit op), _] -> "prefix \"" ++ op ++ "\" " ++ con ++ "" + [_, Terminal (Explicit op), _] -> "binary \"" ++ op ++ "\" " ++ con ++ " PE.AssocLeft" + | Choice _ (Just con) asc es <- cs + ] + ++ "]" + | Choices _ cs <- init css + ] + + raw $ " PE.buildExpressionParser [" ++ ops ++ "] (" + indent + ( if ((length css > 1) || (or [length cs > 1 | Choices _ cs <- css])) then + do { newline ; raw " " } + else + raw " " + ) + choices $ last [cs | Choices _ cs <- css] + raw ")" + unindent + newline + else + do indent + ( if ((length css > 1) || (or [length cs > 1 | Choices _ cs <- css])) then + do { newline ; raw " " } + else + raw " " + ) + choices $ concat [cs | Choices _ cs <- css] + unindent + newline + ) + + choices :: [Choice S.Analysis] -> Compile String () + choices cs = case cs of + [c] -> + do choice c + newline + raw "" + c:cs -> + do choice c + newline + raw "<|> " + choices cs + + choice :: Choice S.Analysis -> Compile String () + choice (c@(Choice _ con _ es)) = + if S.ChoiceIndentedSuffix `elem` S.tags c then + do ves <- return $ init [("v" ++ show k, es!!k) | k <- [0..length es-1]] + con <- + case con of + Nothing -> do { c <- fresh; return $ "C" ++ c } + Just con -> return con + nt <- return $ (\(Indented w (Many (NonTerminal _ nt) _)) -> nt) $ last es + raw $ "withIndent (" + raw "do {" + raw $ join "; " (map element ves) + raw "; " + raw $ "return $ (" ++ join ", " (catMaybes (map arg ves)) ++ ")" + raw "}) " + raw $ "p" ++ nt + raw $ " (\\(" ++ (join ", " $ catMaybes (map arg ves)) ++ ") vs -> " ++ con ++ " " ++ join " " (catMaybes (map arg ves)) ++ " vs)" + else + do ves <- return $ [("v" ++ show k, es!!k) | k <- [0..length es-1]] + con <- + case con of + Nothing -> do { c <- fresh; return $ "C" ++ c } + Just con -> return con + raw "do {" + raw $ join "; " (map element ves) + raw "; " + raw $ "return $ " ++ con ++ " " ++ join " " (catMaybes (map arg ves)) + raw "}" + + element :: (String, Element S.Analysis) -> String + element (v, e) = case e of + NonTerminal _ nt -> v ++ " <- p" ++ nt + May (Many (NonTerminal _ nt) sep) -> + let comb = maybe "many" (\_ -> "sepBy") sep + suffix = maybe "" (\sep -> " (res \"" ++ sep ++ "\")") sep + in v ++ " <- " ++ comb ++ " p" ++ nt ++ suffix + Many (NonTerminal _ nt) sep -> + let comb = maybe "many" (\_ -> "sepBy") sep + suffix = maybe "" (\sep -> " (res \"" ++ sep ++ "\")") sep + in v ++ " <- " ++ comb ++ "1" ++ " p" ++ nt ++ suffix + May (NonTerminal _ nt) -> v ++ " <- option p" ++ nt + Indented False e' -> element (v, e') + Indented True e' -> "" + Terminal t -> terminal v t + _ -> "" + + arg :: (String, Element S.Analysis) -> Maybe String + arg (v, e) = case e of + NonTerminal _ nt -> Just v + Many e' _ -> Just v + May e' -> Just v + Indented _ e' -> Just v + Terminal t -> argT v t + _ -> Nothing + + argT :: String -> Terminal -> Maybe String + argT v t = case t of + Explicit s -> Nothing + StringLiteral -> Just v + NaturalLiteral -> Just v + DecimalLiteral -> Just v + Identifier -> Just v + Constructor -> Just v + Flag -> Just v + RegExp r -> Nothing + + terminal :: String -> Terminal -> String + terminal v t = case t of + Explicit s -> "res \"" ++ s ++ "\"" + StringLiteral -> v ++ " <- literal" + NaturalLiteral -> v ++ " <- natural" + DecimalLiteral -> v ++ " <- decimal" + Identifier -> v ++ " <- identifier" + Constructor -> v ++ " <- con" + Flag -> v ++ " <- flag" + RegExp r -> "regexp" + + in do mapM production ps + nothing + +--eof
+ Text/Imparse/Parse.hs view
@@ -0,0 +1,110 @@+---------------------------------------------------------------- +-- +-- Imparse +-- +-- Text/Imparse/Parse.hs +-- Parser for Imparse parser specification concrete syntax. +-- + +---------------------------------------------------------------- +-- + +module Text.Imparse.Parse (parseParser) + where + +import Data.Char (isAlpha, isAlphaNum) +import Data.Maybe (catMaybes) +import Data.List (isPrefixOf, findIndex) +import Data.List.Split (splitOn, splitWhen) +import Data.Text (unpack, strip, pack) + +import qualified StaticAnalysis.All as A + +import Text.Imparse.AbstractSyntax + +---------------------------------------------------------------- +-- Exported functions. + +parseParser :: A.Analysis a => String -> Either String (Parser a) +parseParser s = + let blocks = splitOn "\n\n" (trim s) + in Right $ Parser A.unanalyzed [] $ catMaybes [pProductionOrDelimiters (trim b) | b <- blocks] + +---------------------------------------------------------------- +-- Parsing functions. + +pProductionOrDelimiters :: A.Analysis a => String -> Maybe (Production a) +pProductionOrDelimiters s = case splitOn "\n" s of + line:lines -> + case splitOn " " line of + [entity, "::="] -> + Just $ + Production A.unanalyzed entity $ + map (Choices A.unanalyzed) $ + map catMaybes $ + splitWhen (\c -> case c of Nothing -> True; _ -> False) $ + [pChoice s | s <- lines, trim s /= ""] + _ -> Nothing + _ -> Nothing + +pChoice :: A.Analysis a => String -> Maybe (Choice a) +pChoice s = case filter ((/=) "") $ splitOn " " (trim s) of + "|":es -> Just $ Choice A.unanalyzed Nothing AssocNone [pElement e | e <- es, e /= ""] + "<":es -> Just $ Choice A.unanalyzed Nothing AssocLeft [pElement e | e <- es, e /= ""] + ">":es -> Just $ Choice A.unanalyzed Nothing AssocRight [pElement e | e <- es, e /= ""] + "~":es -> Just $ Choice A.unanalyzed Nothing AssocFlat [pElement e | e <- es, e /= ""] + c:"|":es -> Just $ Choice A.unanalyzed (Just c) AssocNone [pElement e | e <- es, e /= ""] + c:"<":es -> Just $ Choice A.unanalyzed (Just c) AssocLeft [pElement e | e <- es, e /= ""] + c:">":es -> Just $ Choice A.unanalyzed (Just c) AssocRight [pElement e | e <- es, e /= ""] + c:"~":es -> Just $ Choice A.unanalyzed (Just c) AssocFlat [pElement e | e <- es, e /= ""] + ["^"] -> Nothing + _ -> Nothing + +pElement :: A.Analysis a => String -> Element a +pElement t = case t of + '`':'`':s -> Terminal $ Explicit $ '`':s + "`$" -> Terminal $ StringLiteral + "`#" -> Terminal $ NaturalLiteral + "`#.#" -> Terminal $ DecimalLiteral + "`id" -> Terminal $ Identifier + "`var" -> Terminal $ Identifier + "`con" -> Terminal $ Constructor + "`flag" -> Terminal $ Flag + '`':s -> pNonTerminal s + _ -> Terminal $ Explicit t + +pNonTerminal :: A.Analysis a => String -> Element a +pNonTerminal s = + if length s >= 1 && isAlpha (head s) && and (map isAlphaNum s) then + NonTerminal A.unanalyzed s + else if length s <= 2 then + Error $ "`" ++ s + else if ends "{" "}" s then + Terminal $ RegExp $ tail $ init s + else if ends ">>" "<<" s then + Indented True $ pNonTerminal (drop 2 $ init $ init s) + else if ends ">" "<" s then + Indented False $ pNonTerminal (tail $ init s) + else if ends "[" "]" s then + let s' = tail $ init s + in case findIndex (=='/') s' of + Nothing -> Many (pNonTerminal s') Nothing + Just i -> + let nt = take i s' + sep = drop (i+1) s' + in Many (pNonTerminal nt) (Just sep) + else if ends "(" ")" s then + May $ pNonTerminal (tail $ init s) + else + Error $ "`" ++ s + +---------------------------------------------------------------- +-- Helpful auxiliary functions. + +trim :: String -> String +trim = unpack.strip.pack + +ends :: String -> String -> String -> Bool +ends p s t = isPrefixOf p t && isPrefixOf (reverse s) (reverse t) + +--eof
+ Text/Imparse/Report.hs view
@@ -0,0 +1,89 @@+---------------------------------------------------------------- +-- +-- Imparse +-- +-- Text/Imparse/Report.hs +-- Generation of rich reports from parser definitions. +-- + +---------------------------------------------------------------- +-- + +module Text.Imparse.Report + where + +import Data.String.Utils (join) +import Data.List (nubBy) + +import qualified Text.RichReports as R + +import Text.Imparse.AbstractSyntax + +---------------------------------------------------------------- +-- Functions for converting a parser abstract syntax instance +-- into a rich report. + +instance (R.ToHighlights a, R.ToMessages a) => R.ToReport (Parser a) where + report (Parser _ _ ps) = R.Finalize $ R.Conc [R.report p | p <- ps] + +instance (R.ToHighlights a, R.ToMessages a) => R.ToReport (Production a) where + report (Production a e css) = + R.Block [] [] [ + R.Line [] [R.Space], + R.C R.Variable (R.highlights a) (R.messages a) e, R.Text "::=", + R.BlockIndent [] [] [ + R.Table [ R.report cs | cs <- css ] + ] + ] + +instance (R.ToHighlights a, R.ToMessages a) => R.ToReport (Choices a) where + report (Choices a cs) = + R.Conc $ + [R.report c | c <- cs] ++ + [R.Row [ + R.Field (R.Conc []), + R.Field (R.Atom (R.highlights a) (R.messages a) [R.Text "^"]), + R.Field (R.Conc [])] + ] + +instance (R.ToHighlights a, R.ToMessages a) => R.ToReport (Choice a) where + report (Choice a c asc es) = + R.Row [ + R.Field (maybe (R.Conc []) R.Text c), + R.Field (R.Atom (R.highlights a) (R.messages a) [R.Text $ show asc]), + R.Field (R.Span [] [] [R.Conc [R.report e | e <- es]]) + ] + +instance (R.ToHighlights a, R.ToMessages a) => R.ToReport (Element a) where + report (Terminal t) = R.report t + report (Error s) = R.err_ [R.HighlightError] [] $ "`!!!_" ++ s ++ "_!!!" + report r = + let rec d r = + let bq = if d > 0 then "" else "`" + in case r of + NonTerminal a nt -> R.var_ (R.highlights a) (R.messages a) $ bq ++ nt + Many e ms -> + R.Span [] [] $ + [ R.key (bq ++ "["), rec (d+1) e ] + ++ (maybe [] (\s -> [R.key "/", R.lit s]) ms) + ++ [R.key "]"] + May e -> R.Span [] [] $ [ R.key (bq ++ "("), rec (d+1) e ] ++ [R.key ")"] + Indented w e -> + if w then + R.Span [] [] [R.key (bq ++ ">"), R.report e, R.key "<"] + else + R.Span [] [] [R.key (bq ++ ">>"), R.report e, R.key "<<"] + in rec 0 r + +instance R.ToReport Terminal where + report t = case t of + Explicit s -> R.lit s + StringLiteral -> R.key "`$" + NaturalLiteral -> R.key "`#" + DecimalLiteral -> R.key "`#.#" + Identifier -> R.key "`id" + Constructor -> R.key "`con" + Flag -> R.key "`flag" + RegExp r -> R.Span [] [] [R.key "`{", R.Text r, R.key "}"] + +--eof
imparse.cabal view
@@ -1,5 +1,5 @@ Name: imparse -Version: 0.0.0.1 +Version: 0.0.0.2 Cabal-Version: >= 1.6 License: GPL-3 License-File: LICENSE @@ -11,7 +11,12 @@ Build-Type: Simple Library - Exposed-Modules: Text.Imparse + Exposed-Modules: Text.Imparse, + Text.Imparse.AbstractSyntax, + Text.Imparse.Analysis, + Text.Imparse.Parse, + Text.Imparse.Report, + Text.Imparse.Compile.Haskell Build-Depends: base >= 3 && < 5, MissingH, containers == 0.4.2.1,