module Module (
Name (Name, deconsName), tellName, mainName, noName,
Source (..), maybeEditor,
Identifier (Identifier, deconsIdentifier),
stripIdentifier,
Module,
name,
version,
sourceText,
sourceLocation,
constructors,
controls,
functions,
imports,
source,
FunctionDeclarations,
ConstructorDeclarations,
Version(Version),
noVersion,
initVersion,
nextVersion,
equalVersion,
empty,
addRule,
nameFromIdentifier,
makeFileName,
parse,
) where
import ModuleBase ( Name(Name, deconsName), tellName, mainName, noName,
Version(Version),
noVersion, initVersion, nextVersion, equalVersion,
Source(File, Editor), maybeEditor, formatSource )
import InOut ( Input, Output, input, output )
import Term ( Term )
import TermParser ( lexer )
import Rule ( Rule )
import SourceText
( ModuleRange, Range,
extractModuleName, extractModuleRange, setRangeSourceName )
import qualified ControllerBase as Controller
import qualified Type
import qualified Term
import qualified Rule
import qualified Exception
import qualified Control.Monad.Exception.Synchronous as ME
import qualified Data.Map as Map
import Data.Map ( Map )
import Data.Maybe ( mapMaybe )
import qualified Text.ParserCombinators.Parsec as Parsec
import qualified Text.ParserCombinators.Parsec.Token as Token
import Text.ParserCombinators.Parsec ( (<|>) )
import Text.ParserCombinators.Parsec.Token ( reserved, reservedOp )
import Text.ParserCombinators.Parsec.Expr
( Assoc(AssocLeft, AssocRight, AssocNone) )
import qualified Text.PrettyPrint.HughesPJ as Pretty
import Text.PrettyPrint.HughesPJ
( (<+>), ($$), hsep, sep, hang, punctuate,
render, text, comma, vcat, parens )
import qualified Data.Char as Char
import qualified System.Path as Path
import Data.List.HT ( chop )
import Data.Eq.HT ( equating )
import Control.Applicative ( (<$>) )
import Control.Functor.HT ( void )
indent :: Int
indent = 4
data Import = Import { qualified :: Bool
, source :: Name
, rename :: Maybe Name
}
-- deriving (Show)
parsePortList :: Parsec.Parser [Term.Identifier Range]
parsePortList =
Token.parens lexer $ flip Parsec.sepEndBy (Token.comma lexer) $
(do ident <- input
void $ Parsec.option [] $ Token.parens lexer $
Token.commaSep lexer $ Token.identifier lexer
return ident)
<|>
Term.parenOperator
{-
A semicolon behind an import statement is necessary when parsing
> import Prelude ;
>
> (+) :: a -> a -> a
otherwise the parentheses around the plus
would be interpreted as parentheses behind @Prelude@.
-}
instance Input Import where
input = do
reserved lexer "import"
q <- Parsec.option False $ do reserved lexer "qualified" ; return True
t <- input
r <- Parsec.optionMaybe $ reserved lexer "as" >> input
void $ Parsec.optionMaybe $ reserved lexer "hiding"
void $ Parsec.optionMaybe $ parsePortList
void $ Parsec.option "" $ Token.semi lexer
return $ Import { qualified = q, source = t, rename = r }
instance Output Import where
output i = hsep [ text "import"
, if qualified i then text "qualified" else Pretty.empty
, output $ source i
, case rename i of
Nothing -> Pretty.empty
Just r -> text "as" <+> output r
]
data TypeSig = TypeSig [Term.Identifier Range] [Term Range] (Term Range)
deriving (Show)
parseIdentList :: Parsec.CharParser () [Term.Identifier Range]
parseIdentList = Token.commaSep lexer (input <|> Term.parenOperator)
instance Input TypeSig where
input = do
names <- parseIdentList
reservedOp lexer "::"
context <- Type.parseContext
typeExpr <- Type.parseExpression
void $ Token.semi lexer
return $ TypeSig names context typeExpr
instance Output TypeSig where
output (TypeSig names context typeExpr) =
hang
(hsep ( punctuate ( text "," ) $ map output names ) <+> text "::")
indent
(sep
[if null context
then Pretty.empty
else parens ( hsep ( punctuate ( text "," ) $
map output context ) ) <+> text "=>",
output typeExpr <+> text ";"])
data Data = Data { dataLhs :: Term Range
, dataRhs :: [ Term Range ]
}
deriving (Show)
instance Input Data where
input = do
reserved lexer "data"
l <- input
reservedOp lexer "="
rs <- Parsec.sepBy input ( reservedOp lexer "|" )
void $ Token.semi lexer
return $ Data { dataLhs = l, dataRhs = rs }
instance Output Data where
output d = text "data" <+> output ( dataLhs d ) <+> text "="
$$ hsep ( punctuate ( text "|" ) $ map output ( dataRhs d ) ) <+> text ";"
data Type = Type { typeLhs :: Term Range
, typeRhs :: Term Range
}
deriving (Show)
instance Input Type where
input = do
reserved lexer "type"
l <- input
reservedOp lexer "="
r <- Type.parseExpression
void $ Token.semi lexer
return $ Type { typeLhs = l, typeRhs = r }
instance Output Type where
output d =
hang
( text "type" <+> output ( typeLhs d ) <+> text "=" )
indent
( output ( typeRhs d ) <+> text ";" )
data Infix = Infix Assoc Int [ Term.Identifier Range ]
showAssoc :: Assoc -> String
showAssoc AssocLeft = "AssocLeft"
showAssoc AssocRight = "AssocRight"
showAssoc AssocNone = "AssocNone"
instance Show Infix where
showsPrec p (Infix assoc prec idents) =
showParen (p>10) $
showString "Infix " .
showString (showAssoc assoc) .
showString " " .
shows prec .
showString " " .
shows idents
instance Input Infix where
input = do
assoc <-
Parsec.try $
Token.lexeme lexer $
Parsec.string "infix" >>
((Parsec.char 'l' >> return AssocLeft)
<|>
(Parsec.char 'r' >> return AssocRight)
<|>
return AssocNone)
prec <-
fmap (\c -> Char.ord c - Char.ord '0') $
Token.lexeme lexer Parsec.digit
ops <- Parsec.sepBy1 Term.infixOperator (Token.comma lexer)
void $ Parsec.option "" $ Token.semi lexer
return $ Infix assoc prec ops
instance Output Infix where
output (Infix assoc prec idents) =
let assocStr =
case assoc of
AssocLeft -> "l"
AssocRight -> "r"
AssocNone -> ""
in hang
(text ( "infix" ++ assocStr ) <+> text ( show prec ))
indent
(hsep ( punctuate comma $ map output idents ) <+> text ";")
data Declaration = TypeSignature TypeSig
| RuleDeclaration (Rule Range)
| TypeDeclaration Type
| DataDeclaration Data
| InfixDeclaration Infix
deriving (Show)
instance Input Declaration where
input = fmap DataDeclaration input
<|> fmap InfixDeclaration input
<|> fmap TypeDeclaration input
<|> fmap TypeSignature (do
names <- Parsec.try $ do
names <- parseIdentList
reservedOp lexer "::"
return names
context <-
Parsec.try Type.parseContext
<|>
return []
typeExpr <- Type.parseExpression
void $ Token.semi lexer
return $ TypeSig names context typeExpr)
<|> fmap RuleDeclaration input
instance Output Declaration where
output decl = case decl of
TypeSignature d -> output d
DataDeclaration d -> output d
TypeDeclaration d -> output d
RuleDeclaration d -> output d
InfixDeclaration d -> output d
-- | on module parsing:
-- identifiers contain information on their source location.
-- their sourceName (as used by Parsec) is the "show"
-- of the module name (which is an identifier).
-- So, sourceName is NOT the actual file name.
-- instead, the actual file name is kept in sourceLocation (defined here)
data Module =
Module
{ name :: Name
, version :: Maybe Version
, imports :: [ Import ]
, declarations :: [ Declaration ]
, functions :: FunctionDeclarations
, constructors :: ConstructorDeclarations
, controls :: Controller.Assignments
, sourceText :: String
, sourceLocation :: Path.AbsFile
}
nameFromIdentifier :: Term.Identifier ModuleRange -> Name
nameFromIdentifier = extractModuleName . Term.range
makeFileName :: Name -> Path.RelFile
makeFileName (Name n) =
Path.addExtension (Path.joinPath $ chop ('.'==) n) "hs"
newtype Identifier = Identifier { deconsIdentifier :: String }
deriving (Eq, Ord)
stripIdentifier :: Term.Identifier range -> Identifier
stripIdentifier = Identifier . Term.name
type FunctionDeclarations =
Map Identifier (Term.Identifier ModuleRange, [Rule ModuleRange])
type ConstructorDeclarations =
Map Identifier (Term.Identifier ModuleRange)
empty :: Name -> Module
empty moduleName =
Module {
name = moduleName,
version = noVersion,
imports = [],
sourceText = show $ outputModuleHead moduleName,
sourceLocation = Path.file "/dev/null",
functions = Map.empty,
constructors = Map.empty,
controls = Map.empty,
declarations = []
}
-- | add, or replace (if rule with exact same lhs is already present)
addRule :: Rule ModuleRange -> Module -> Module
addRule rule@(Rule.Rule ident params _rhs) m =
let matchParams ps = Term.equatingList Term.match ps . Rule.parameters
in
m { declarations =
revUpdate
(\d -> case d of
RuleDeclaration r' ->
equating Term.name (extractModuleRange <$> ident) (Rule.name r') &&
matchParams (map (fmap extractModuleRange) params) r'
_ -> False)
(RuleDeclaration (extractModuleRange <$> rule)) $
declarations m,
functions =
Map.insertWith
(\_ -> (,) ident . revUpdate (matchParams params) rule . snd)
(stripIdentifier ident) (ident, [rule]) $
functions m }
{- |
replace a matching element if it exists
and append the new element otherwise.
-}
update :: (a -> Bool) -> a -> [a] -> [a]
update matches x xs =
let ( pre, post ) = break matches xs
in pre ++ x : drop 1 post
{- |
replace a matching element if it exists
and prepend the new element otherwise.
-}
revUpdate :: (a -> Bool) -> a -> [a] -> [a]
revUpdate p x = reverse . update p x . reverse
makeFunctions :: Name -> Version -> [Declaration] -> FunctionDeclarations
makeFunctions srcName vers =
Map.fromListWith (\(nm,xs) (_,ys) -> (nm, ys++xs)) .
mapMaybe (\decl ->
case decl of
RuleDeclaration rule -> Just $
let nm = Rule.name rule
in (stripIdentifier nm,
(setRangeSourceName srcName vers <$> nm,
[setRangeSourceName srcName vers <$> rule]))
_ -> Nothing)
makeConstructors :: Name -> Version -> [Declaration] -> ConstructorDeclarations
makeConstructors srcName vers decls = Map.fromList $ do
DataDeclaration (Data {dataRhs = summands}) <- decls
Term.Node ident _ <- summands
return (stripIdentifier ident, setRangeSourceName srcName vers <$> ident)
makeControllers ::
Name -> Version -> [Declaration] -> Exception.Monad Controller.Assignments
makeControllers srcName vers decls =
flip (foldr
(\r go a -> Controller.collect r >>= Controller.union a >>= go)
return) Map.empty $ do
Module.RuleDeclaration rule <- decls
return $ setRangeSourceName srcName vers <$> Rule.rhs rule
{- |
Replace source names in all identifiers.
We can only do this after parsing
because if a parse error happens, module renaming will be skipped
and thus parse errors must refer
to the old module name or to the file name.
-}
fromDeclarations ::
Path.AbsFile -> String ->
Name -> Version -> [Import] -> [Declaration] ->
Controller.Assignments -> Module
fromDeclarations srcLoc srcText moduleName vers imps decls ctrls =
Module {
name = moduleName,
version = Just vers,
imports = imps,
declarations = decls,
functions = makeFunctions moduleName vers decls,
constructors = makeConstructors moduleName vers decls,
controls = ctrls,
sourceText = srcText,
sourceLocation = srcLoc
}
{-
We do not define the instance Input Module,
because for proper module parsing
the caller should provide the source file path and content.
instance Input Module where
input = do
-}
parser :: Parsec.Parser (Name, [Import], [Declaration])
parser = do
m <- Parsec.option mainName $ do
reserved lexer "module"
m <- input
void $ Parsec.optionMaybe parsePortList
reserved lexer "where"
return m
is <- Parsec.many input
ds <- Parsec.many input
Parsec.eof
return (m,is,ds)
parse ::
Version -> Maybe Name -> Path.AbsFile -> String -> Exception.Monad Module
parse vers srcName srcLoc srcText =
let src = maybe (File srcLoc) Editor srcName
in either
(ME.Exception . Exception.messageFromParserError src)
(\(m,is,ds) ->
fromDeclarations srcLoc srcText m vers is ds
<$> makeControllers m vers ds) $
Parsec.parse parser (formatSource src) srcText
outputModuleHead :: Name -> Pretty.Doc
outputModuleHead nm =
hsep [ text "module", output nm, text "where" ]
instance Output Module where
output p = vcat
[ outputModuleHead (name p)
, vcat $ map output $ imports p
, vcat $ map output $ declarations p
]
instance Show Module where show = render . output
-- instance Read Module where readsPrec = parsecReader