~ubuntu-branches/ubuntu/raring/agda/raring-proposed

« back to all changes in this revision

Viewing changes to src/full/Agda/Syntax/Parser/Parser.y

  • Committer: Bazaar Package Importer
  • Author(s): Iain Lane
  • Date: 2010-01-05 23:43:20 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20100105234320-6ksc0sdsfhtweknu
Tags: 2.2.6-1
* New upstream release 2.2.6, for headlines please see:
  http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Main.Version-2-2-6
* debian/control
  + Bump standards-version to 3.8.3, no changes
  + Fix Vcs-Git to point to correct URL
  + Update build-depends for new upstream release
  + Undo arch/indep split per current pkg-haskell practice
  + Add Homepage field
* debian/copyright: Fix encoding to UTF-8 (thanks Lintian) 
* debian/README.source: Remove, no repacking so not necessary any more 
* debian/50agda.el:
  + Only load file if it exists, prevents a non-intrusive emacs warning
    where 50agda.el is left on system when package is removed. 
    (Closes: #559197). 
  + Do not load file on XEmacs — agda-mode is not compatible with XEmacs.

Show diffs side-by-side

added added

removed removed

Lines of Context:
6
6
      moduleParser
7
7
    , exprParser
8
8
    , tokensParser
 
9
    , tests
9
10
    ) where
10
11
 
 
12
import Control.Arrow
11
13
import Control.Monad
12
14
import Control.Monad.State
13
 
import Data.Char  (isDigit)
 
15
import Data.Char
14
16
import Data.List
15
17
import Data.Maybe
16
18
import qualified Data.Traversable as T
17
19
 
18
 
import Agda.Syntax.Position
 
20
import Agda.Syntax.Position hiding (tests)
19
21
import Agda.Syntax.Parser.Monad
20
22
import Agda.Syntax.Parser.Lexer
21
23
import Agda.Syntax.Parser.Tokens
27
29
import Agda.Syntax.Literal
28
30
 
29
31
import Agda.Utils.Monad
 
32
import Agda.Utils.QuickCheck
 
33
import Agda.Utils.TestHelpers
30
34
 
31
35
}
32
36
 
44
48
%nonassoc '->'
45
49
 
46
50
%token
47
 
    'let'       { TokKeyword KwLet $$ }
48
 
    'in'        { TokKeyword KwIn $$ }
49
 
    'where'     { TokKeyword KwWhere $$ }
50
 
    'with'      { TokKeyword KwWith $$ }
51
 
    'postulate' { TokKeyword KwPostulate $$ }
52
 
    'primitive' { TokKeyword KwPrimitive $$ }
53
 
    'open'      { TokKeyword KwOpen $$ }
54
 
    'import'    { TokKeyword KwImport $$ }
55
 
    'using'     { TokKeyword KwUsing $$ }
56
 
    'hiding'    { TokKeyword KwHiding $$ }
57
 
    'renaming'  { TokKeyword KwRenaming $$ }
58
 
    'to'        { TokKeyword KwTo $$ }
59
 
    'public'    { TokKeyword KwPublic $$ }
60
 
    'module'    { TokKeyword KwModule $$ }
61
 
    'data'      { TokKeyword KwData $$ }
62
 
    'codata'    { TokKeyword KwCoData $$ }
63
 
    'record'    { TokKeyword KwRecord $$ }
64
 
    'field'     { TokKeyword KwField $$ }
65
 
    'infix'     { TokKeyword KwInfix $$ }
66
 
    'infixl'    { TokKeyword KwInfixL $$ }
67
 
    'infixr'    { TokKeyword KwInfixR $$ }
68
 
    'mutual'    { TokKeyword KwMutual $$ }
69
 
    'abstract'  { TokKeyword KwAbstract $$ }
70
 
    'private'   { TokKeyword KwPrivate $$ }
71
 
    'Prop'      { TokKeyword KwProp $$ }
72
 
    'Set'       { TokKeyword KwSet $$ }
73
 
    'forall'    { TokKeyword KwForall $$ }
74
 
    'OPTIONS'   { TokKeyword KwOPTIONS $$ }
75
 
    'BUILTIN'   { TokKeyword KwBUILTIN $$ }
76
 
    'IMPORT'    { TokKeyword KwIMPORT $$ }
77
 
    'COMPILED'  { TokKeyword KwCOMPILED $$ }
 
51
    'let'           { TokKeyword KwLet $$ }
 
52
    'in'            { TokKeyword KwIn $$ }
 
53
    'where'         { TokKeyword KwWhere $$ }
 
54
    'with'          { TokKeyword KwWith $$ }
 
55
    'rewrite'       { TokKeyword KwRewrite $$ }
 
56
    'postulate'     { TokKeyword KwPostulate $$ }
 
57
    'primitive'     { TokKeyword KwPrimitive $$ }
 
58
    'open'          { TokKeyword KwOpen $$ }
 
59
    'import'        { TokKeyword KwImport $$ }
 
60
    'using'         { TokKeyword KwUsing $$ }
 
61
    'hiding'        { TokKeyword KwHiding $$ }
 
62
    'renaming'      { TokKeyword KwRenaming $$ }
 
63
    'to'            { TokKeyword KwTo $$ }
 
64
    'public'        { TokKeyword KwPublic $$ }
 
65
    'module'        { TokKeyword KwModule $$ }
 
66
    'data'          { TokKeyword KwData $$ }
 
67
    'codata'        { TokKeyword KwCoData $$ }
 
68
    'record'        { TokKeyword KwRecord $$ }
 
69
    'constructor'   { TokKeyword KwConstructor $$ }
 
70
    'field'         { TokKeyword KwField $$ }
 
71
    'infix'         { TokKeyword KwInfix $$ }
 
72
    'infixl'        { TokKeyword KwInfixL $$ }
 
73
    'infixr'        { TokKeyword KwInfixR $$ }
 
74
    'mutual'        { TokKeyword KwMutual $$ }
 
75
    'abstract'      { TokKeyword KwAbstract $$ }
 
76
    'private'       { TokKeyword KwPrivate $$ }
 
77
    'Prop'          { TokKeyword KwProp $$ }
 
78
    'Set'           { TokKeyword KwSet $$ }
 
79
    'forall'        { TokKeyword KwForall $$ }
 
80
    'OPTIONS'       { TokKeyword KwOPTIONS $$ }
 
81
    'BUILTIN'       { TokKeyword KwBUILTIN $$ }
 
82
    'IMPORT'        { TokKeyword KwIMPORT $$ }
 
83
    'IMPOSSIBLE'    { TokKeyword KwIMPOSSIBLE $$ }
 
84
    'COMPILED'      { TokKeyword KwCOMPILED $$ }
78
85
    'COMPILED_DATA' { TokKeyword KwCOMPILED_DATA $$ }
79
86
    'COMPILED_TYPE' { TokKeyword KwCOMPILED_TYPE $$ }
80
 
    'LINE'      { TokKeyword KwLINE $$ }
81
87
 
82
88
    setN        { TokSetN $$ }
83
89
    tex         { TokTeX $$ }
133
139
    | 'in'          { TokKeyword KwIn $1 }
134
140
    | 'where'       { TokKeyword KwWhere $1 }
135
141
    | 'with'        { TokKeyword KwWith $1 }
 
142
    | 'rewrite'     { TokKeyword KwRewrite $1 }
136
143
    | 'postulate'   { TokKeyword KwPostulate $1 }
137
144
    | 'primitive'   { TokKeyword KwPrimitive $1 }
138
145
    | 'open'        { TokKeyword KwOpen $1 }
146
153
    | 'data'        { TokKeyword KwData $1 }
147
154
    | 'codata'      { TokKeyword KwCoData $1 }
148
155
    | 'record'      { TokKeyword KwRecord $1 }
 
156
    | 'constructor' { TokKeyword KwConstructor $1 }
149
157
    | 'field'       { TokKeyword KwField $1 }
150
158
    | 'infix'       { TokKeyword KwInfix $1 }
151
159
    | 'infixl'      { TokKeyword KwInfixL $1 }
162
170
    | 'COMPILED'    { TokKeyword KwCOMPILED $1 }
163
171
    | 'COMPILED_DATA'{ TokKeyword KwCOMPILED_DATA $1 }
164
172
    | 'COMPILED_TYPE'{ TokKeyword KwCOMPILED_TYPE $1 }
165
 
    | 'LINE'        { TokKeyword KwLINE $1 }
166
173
 
167
174
    | setN          { TokSetN $1 }
168
175
    | tex           { TokTeX $1 }
269
276
Id :: { Name }
270
277
Id : id     {% mkName $1 }
271
278
 
 
279
-- Space separated list of one or more identifiers.
 
280
SpaceIds :: { [Name] }
 
281
SpaceIds
 
282
    : Id SpaceIds { $1 : $2 }
 
283
    | Id          { [$1] }
 
284
 
 
285
-- Space separated list of one or more identifiers, some of which may
 
286
-- be surrounded by braces.
 
287
HiddenIds :: { [(Hiding, Name)] }
 
288
HiddenIds
 
289
    : Id HiddenIds               { (NotHidden, $1) : $2 }
 
290
    | Id                         { [(NotHidden, $1)] }
 
291
    | '{' SpaceIds '}' HiddenIds { map ((,) Hidden) $2 ++ $4 }
 
292
    | '{' SpaceIds '}'           { map ((,) Hidden) $2 }
 
293
 
272
294
-- Qualified operators are treated as identifiers, i.e. they have to be back
273
295
-- quoted to appear infix.
274
296
QId :: { QName }
323
345
 
324
346
{-  Expressions. You might expect lambdas and lets to appear in the first
325
347
    expression category (lowest precedence). The reason they don't is that we
326
 
    wan't to parse things like
 
348
    want to parse things like
327
349
 
328
350
        m >>= \x -> k x
329
351
 
566
588
-- A left hand side of a function clause. We parse it as an expression, and
567
589
-- then check that it is a valid left hand side.
568
590
LHS :: { LHS }
569
 
LHS : Expr1 WithExpressions          {% exprToLHS $1 >>= \p -> return (p $2) }
570
 
    | '...' WithPats WithExpressions { Ellipsis (fuseRange $1 $3) $2 $3 }
 
591
LHS : Expr1 RewriteEquations WithExpressions
 
592
        {% exprToLHS $1 >>= \p -> return (p $2 $3) }
 
593
    | '...' WithPats RewriteEquations WithExpressions
 
594
        { Ellipsis (fuseRange $1 $3) $2 $3 $4 }
571
595
 
572
596
WithPats :: { [Pattern] }
573
597
WithPats : {- empty -}  { [] }
579
603
WithExpressions :: { [Expr] }
580
604
WithExpressions
581
605
  : {- empty -} { [] }
582
 
  | 'with' Expr { case $2 of { WithApp _ e es -> e : es; e -> [e] } }
 
606
  | 'with' Expr
 
607
      { case $2 of { WithApp _ e es -> e : es; e -> [e] } }
 
608
 
 
609
RewriteEquations :: { [Expr] }
 
610
RewriteEquations
 
611
  : {- empty -} { [] }
 
612
  | 'rewrite' Expr
 
613
      { case $2 of { WithApp _ e es -> e : es; e -> [e] } }
583
614
 
584
615
-- Where clauses are optional.
585
616
WhereClause :: { WhereClause }
593
624
    Different kinds of declarations
594
625
 --------------------------------------------------------------------------}
595
626
 
 
627
-- Top-level definitions.
596
628
Declaration :: { [Declaration] }
597
629
Declaration
598
630
    : TypeSig       { [$1] }
623
654
TypeSig :: { Declaration }
624
655
TypeSig : Id ':' Expr   { TypeSig $1 $3 }
625
656
 
 
657
-- Type signatures of the form "n1 n2 n3 ... : Type", with at least
 
658
-- one bound name.
 
659
TypeSigs :: { [Declaration] }
 
660
TypeSigs : SpaceIds ':' Expr { map (flip TypeSig $3) $1 }
 
661
 
 
662
-- A variant of TypeSigs where any sub-sequence of names can be marked
 
663
-- as hidden using braces: {n1 n2} n3 n4 {n5} {n6} ... : Type.
 
664
HiddenTypeSigs :: { [(Hiding, Declaration)] }
 
665
HiddenTypeSigs : HiddenIds ':' Expr { map (id *** flip TypeSig $3) $1 }
626
666
 
627
667
-- Function declarations. The left hand side is parsed as an expression to allow
628
668
-- declarations like 'x::xs ++ ys = e', when '::' has higher precedence than '++'.
644
684
-- Record declarations.
645
685
Record :: { Declaration }
646
686
Record : 'record' Id LamBindings0 ':' Expr 'where'
647
 
            Declarations0 { Record (getRange ($1, $6, $7)) $2 (map addType $3) $5 $7 }
 
687
            RecordDeclarations
 
688
         { Record (getRange ($1, $6, $7)) $2 (fst $7) (map addType $3) $5 (snd $7) }
648
689
 
 
690
-- Declaration of record constructor name.
 
691
RecordConstructorName :: { Name }
 
692
RecordConstructorName : 'constructor' Id { $2 }
649
693
 
650
694
-- Fixity declarations.
651
695
Infix :: { Declaration }
655
699
 
656
700
-- Field declarations.
657
701
Fields :: { [Declaration] }
658
 
Fields : 'field' TypeSignatures { let toField (TypeSig x t) = Field x t in map toField $2 }
 
702
Fields : 'field' HiddenTypeSignatures
 
703
            { let toField (h, TypeSig x t) = Field h x t in map toField $2 }
659
704
 
660
705
-- Mutually recursive declarations.
661
706
Mutual :: { Declaration }
676
721
Postulate :: { Declaration }
677
722
Postulate : 'postulate' TypeSignatures  { Postulate (fuseRange $1 $2) $2 }
678
723
 
679
 
 
680
724
-- Primitives. Can only contain type signatures.
681
725
Primitive :: { Declaration }
682
726
Primitive : 'primitive' TypeSignatures  { Primitive (fuseRange $1 $2) $2 }
683
727
 
684
 
 
685
728
-- Open
686
729
Open :: { Declaration }
687
730
Open : 'open' ModuleName OpenArgs ImportDirective {
739
782
TopLevelPragma :: { Pragma }
740
783
TopLevelPragma
741
784
  : OptionsPragma { $1 }
742
 
  | LinePragma    { $1 }
743
785
 
744
786
DeclarationPragma :: { Pragma }
745
787
DeclarationPragma
746
788
  : BuiltinPragma      { $1 }
747
 
  | LinePragma         { $1 }
748
789
  | CompiledPragma     { $1 }
749
790
  | CompiledDataPragma { $1 }
750
791
  | CompiledTypePragma { $1 }
751
792
  | ImportPragma       { $1 }
 
793
  | ImpossiblePragma   { $1 }
752
794
 
753
795
OptionsPragma :: { Pragma }
754
796
OptionsPragma : '{-#' 'OPTIONS' PragmaStrings '#-}' { OptionsPragma (fuseRange $1 $4) $3 }
775
817
 
776
818
ImportPragma :: { Pragma }
777
819
ImportPragma
778
 
  : '{-#' 'IMPORT' PragmaStrings '#-}'
779
 
    { ImportPragma (fuseRange $1 $4) (unwords $3) }
780
 
 
781
 
 
782
 
LinePragma :: { Pragma }
783
 
LinePragma
784
 
    : '{-#' 'LINE' string string '#-}' {% do
785
 
      let r = fuseRange $1 $5
786
 
          parseFile (i, f)
787
 
            | head f == '"' && last f == '"'  = return $ init (tail f)
788
 
            | otherwise = parseErrorAt (iStart i) $ "Expected \"filename\", found " ++ f
789
 
          parseLine (i, l)
790
 
            | all isDigit l = return $ read l
791
 
            | otherwise     = parseErrorAt (iStart i) $ "Expected line number, found " ++ l
792
 
      line <- parseLine $3
793
 
      file <- parseFile $4
794
 
      currentPos <- fmap parsePos get
795
 
      setParsePos $ Pn
796
 
        { srcFile = file
797
 
        , posPos  = posPos currentPos
798
 
        , posLine = line
799
 
        , posCol  = 1
800
 
        }
801
 
      return $ LinePragma r line file
 
820
  : '{-#' 'IMPORT' string '#-}'
 
821
    {% let s = snd $3 in
 
822
       if validHaskellModuleName s
 
823
       then return $ ImportPragma (fuseRange $1 $4) s
 
824
       else parseError $ "Malformed module name: " ++ s ++ "."
802
825
    }
803
826
 
 
827
ImpossiblePragma :: { Pragma }
 
828
  : '{-#' 'IMPOSSIBLE' '#-}'  { ImpossiblePragma (fuseRange $1 $3) }
 
829
 
804
830
{--------------------------------------------------------------------------
805
831
    Sequences of declarations
806
832
 --------------------------------------------------------------------------}
807
833
 
 
834
-- Non-empty list of type signatures, with several identifiers allowed
 
835
-- for every signature.
808
836
TypeSignatures :: { [TypeSignature] }
809
837
TypeSignatures
810
838
    : TeX vopen TypeSignatures1 TeX close   { reverse $3 }
816
840
-- Inside the layout block.
817
841
TypeSignatures1 :: { [TypeSignature] }
818
842
TypeSignatures1
819
 
    : TypeSignatures1 semi TeX TypeSig  { $4 : $1 }
820
 
    | TeX TypeSig                       { [$2] }
 
843
    : TypeSignatures1 semi TeX TypeSigs { reverse $4 ++ $1 }
 
844
    | TeX TypeSigs                      { reverse $2 }
 
845
 
 
846
-- A variant of TypeSignatures which uses HiddenTypeSigs instead of
 
847
-- TypeSigs.
 
848
HiddenTypeSignatures :: { [(Hiding, TypeSignature)] }
 
849
HiddenTypeSignatures
 
850
    : TeX vopen HiddenTypeSignatures1 TeX close   { reverse $3 }
 
851
 
 
852
-- Inside the layout block.
 
853
HiddenTypeSignatures1 :: { [(Hiding, TypeSignature)] }
 
854
HiddenTypeSignatures1
 
855
    : HiddenTypeSignatures1 semi TeX HiddenTypeSigs { reverse $4 ++ $1 }
 
856
    | TeX HiddenTypeSigs                            { reverse $2 }
821
857
 
822
858
-- Constructors are type signatures. But constructor lists can be empty.
823
859
Constructors :: { [Constructor] }
824
860
Constructors
825
 
    : TypeSignatures      { $1 }
826
 
    | TeX vopen TeX close { [] }
 
861
    : TeX vopen TeX close { [] }
 
862
    | TypeSignatures      { $1 }
 
863
 
 
864
-- Record declarations, including an optional record constructor name.
 
865
RecordDeclarations :: { (Maybe Name, [Declaration]) }
 
866
RecordDeclarations
 
867
    : TeX vopen                                              TeX close { (Nothing, []) }
 
868
    | TeX vopen TeX RecordConstructorName                    TeX close { (Just $4, []) }
 
869
    | TeX vopen TeX RecordConstructorName semi Declarations1 TeX close { (Just $4, reverse $6) }
 
870
    | TeX vopen                                Declarations1 TeX close { (Nothing, reverse $3) }
827
871
 
828
872
-- Arbitrary declarations
829
873
Declarations :: { [Declaration] }
855
899
exprParser :: Parser Expr
856
900
 
857
901
-- | Parse a module.
858
 
moduleParser :: Parser ([Pragma], [Declaration])
 
902
moduleParser :: Parser Module
859
903
 
860
904
 
861
905
{--------------------------------------------------------------------------
939
983
        names (Using xs)    = xs
940
984
        names (Hiding xs)   = xs
941
985
 
 
986
-- | Breaks up a string into substrings. Returns every maximal
 
987
-- subsequence of zero or more characters distinct from @'.'@.
 
988
--
 
989
-- > splitOnDots ""         == [""]
 
990
-- > splitOnDots "foo.bar"  == ["foo", "bar"]
 
991
-- > splitOnDots ".foo.bar" == ["", "foo", "bar"]
 
992
-- > splitOnDots "foo.bar." == ["foo", "bar", ""]
 
993
-- > splitOnDots "foo..bar" == ["foo", "", "bar"]
 
994
splitOnDots :: String -> [String]
 
995
splitOnDots ""        = [""]
 
996
splitOnDots ('.' : s) = [] : splitOnDots s
 
997
splitOnDots (c   : s) = case splitOnDots s of
 
998
  p : ps -> (c : p) : ps
 
999
 
 
1000
prop_splitOnDots = and
 
1001
  [ splitOnDots ""         == [""]
 
1002
  , splitOnDots "foo.bar"  == ["foo", "bar"]
 
1003
  , splitOnDots ".foo.bar" == ["", "foo", "bar"]
 
1004
  , splitOnDots "foo.bar." == ["foo", "bar", ""]
 
1005
  , splitOnDots "foo..bar" == ["foo", "", "bar"]
 
1006
  ]
 
1007
 
 
1008
-- | Returns 'True' iff the name is a valid Haskell (hierarchical)
 
1009
-- module name.
 
1010
validHaskellModuleName :: String -> Bool
 
1011
validHaskellModuleName = all ok . splitOnDots
 
1012
  where
 
1013
  -- Checks if a dot-less module name is well-formed.
 
1014
  ok :: String -> Bool
 
1015
  ok []      = False
 
1016
  ok (c : s) =
 
1017
    isUpper c &&
 
1018
    all (\c -> isLower c || c == '_' ||
 
1019
               isUpper c ||
 
1020
               generalCategory c == DecimalNumber ||
 
1021
               c == '\'')
 
1022
        s
 
1023
 
942
1024
{--------------------------------------------------------------------------
943
1025
    Patterns
944
1026
 --------------------------------------------------------------------------}
945
1027
 
946
1028
-- | Turn an expression into a left hand side.
947
 
exprToLHS :: Expr -> Parser ([Expr] -> LHS)
 
1029
exprToLHS :: Expr -> Parser ([Expr] -> [Expr] -> LHS)
948
1030
exprToLHS e = case e of
949
1031
  WithApp r e es -> LHS <$> exprToPattern e <*> mapM exprToPattern es
950
1032
  _              -> LHS <$> exprToPattern e <*> return []
972
1054
          let Just pos = rStart $ getRange e in
973
1055
          parseErrorAt pos $ "Not a valid pattern: " ++ show e
974
1056
 
 
1057
{--------------------------------------------------------------------------
 
1058
    Tests
 
1059
 --------------------------------------------------------------------------}
 
1060
 
 
1061
-- | Test suite.
 
1062
tests :: IO Bool
 
1063
tests = runTests "Agda.Syntax.Parser.Parser"
 
1064
  [ quickCheck' prop_splitOnDots
 
1065
  ]
 
1066
 
975
1067
}